{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Sandwich.TH.ModuleMap where
import Control.Monad
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (isNothing)
import System.Directory
import System.FilePath
type ModuleMap = M.Map String String
type ReverseModuleMap = M.Map String String
buildModuleMap :: FilePath -> String -> IO ModuleMap
buildModuleMap :: FilePath -> FilePath -> IO ModuleMap
buildModuleMap FilePath
baseDir FilePath
modulePrefix = (FilePath -> Bool)
-> (ModuleMap -> FilePath -> IO ModuleMap)
-> ModuleMap
-> FilePath
-> IO ModuleMap
forall b.
(FilePath -> Bool)
-> (b -> FilePath -> IO b) -> b -> FilePath -> IO b
traverseDir (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True) (\ModuleMap
x FilePath
y -> ModuleMap -> IO ModuleMap
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleMap -> IO ModuleMap) -> ModuleMap -> IO ModuleMap
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ModuleMap -> FilePath -> ModuleMap
addModuleToMap FilePath
baseDir FilePath
modulePrefix ModuleMap
x FilePath
y) ModuleMap
forall a. Monoid a => a
mempty FilePath
baseDir
addModuleToMap :: FilePath -> String -> ModuleMap -> FilePath -> ModuleMap
addModuleToMap :: FilePath -> FilePath -> ModuleMap -> FilePath -> ModuleMap
addModuleToMap FilePath
relativeTo FilePath
modulePrefix ModuleMap
mm path :: FilePath
path@(FilePath -> FilePath
takeExtension -> FilePath
".hs") = case [FilePath]
pathParts of
[] -> ModuleMap
mm
[FilePath]
_ -> FilePath -> FilePath -> ModuleMap -> ModuleMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
moduleName (FilePath
modulePrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
"." [FilePath]
pathParts)) ModuleMap
mm
where
relativePath :: FilePath
relativePath = (FilePath -> FilePath
takeFileName FilePath
relativeTo) FilePath -> FilePath -> FilePath
</> (FilePath -> FilePath -> FilePath
makeRelative FilePath
relativeTo FilePath
path)
pathParts :: [FilePath]
pathParts = FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
dropExtension FilePath
relativePath
baseModuleName :: FilePath
baseModuleName = [FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
pathParts
moduleName :: FilePath
moduleName = [FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
doesNotExist (FilePath
baseModuleName FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath
baseModuleName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
n | Integer
n <- [Integer
1..]])
doesNotExist :: FilePath -> Bool
doesNotExist FilePath
x = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing (FilePath -> ModuleMap -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
x ModuleMap
mm)
addModuleToMap FilePath
_ FilePath
_ ModuleMap
mm FilePath
_ = ModuleMap
mm
traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b
traverseDir :: (FilePath -> Bool)
-> (b -> FilePath -> IO b) -> b -> FilePath -> IO b
traverseDir FilePath -> Bool
validDir b -> FilePath -> IO b
transition =
let go :: b -> FilePath -> IO b
go b
state FilePath
dirPath = do
[FilePath]
names <- FilePath -> IO [FilePath]
listDirectory FilePath
dirPath
let paths :: [FilePath]
paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
dirPath FilePath -> FilePath -> FilePath
</>) [FilePath]
names
([FilePath]
dirPaths, [FilePath]
filePaths) <- (FilePath -> IO Bool) -> [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
doesDirectoryExist [FilePath]
paths
b
state' <- (b -> FilePath -> IO b) -> b -> [FilePath] -> IO b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM b -> FilePath -> IO b
transition b
state [FilePath]
filePaths
(b -> FilePath -> IO b) -> b -> [FilePath] -> IO b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM b -> FilePath -> IO b
go b
state' ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
validDir [FilePath]
dirPaths)
in b -> FilePath -> IO b
go
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
_ [] = ([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
partitionM a -> m Bool
f (a
x:[a]
xs) = do
Bool
res <- a -> m Bool
f a
x
([a]
as,[a]
bs) <- (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
([a], [a]) -> m ([a], [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
x | Bool
res][a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
as, [a
x | Bool -> Bool
not Bool
res][a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
bs)