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


-- Map from qualified import name to path
type ModuleMap = M.Map String String
type ReverseModuleMap = M.Map String String

buildModuleMap :: FilePath -> String -> IO ModuleMap
buildModuleMap :: String -> String -> IO ModuleMap
buildModuleMap String
baseDir String
modulePrefix = (String -> Bool)
-> (ModuleMap -> String -> IO ModuleMap)
-> ModuleMap
-> String
-> IO ModuleMap
forall b.
(String -> Bool) -> (b -> String -> IO b) -> b -> String -> IO b
traverseDir (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True) (\ModuleMap
x String
y -> ModuleMap -> IO ModuleMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleMap -> IO ModuleMap) -> ModuleMap -> IO ModuleMap
forall a b. (a -> b) -> a -> b
$ String -> String -> ModuleMap -> String -> ModuleMap
addModuleToMap String
baseDir String
modulePrefix ModuleMap
x String
y) ModuleMap
forall a. Monoid a => a
mempty String
baseDir

addModuleToMap :: FilePath -> String -> ModuleMap -> FilePath -> ModuleMap
addModuleToMap :: String -> String -> ModuleMap -> String -> ModuleMap
addModuleToMap String
relativeTo String
modulePrefix ModuleMap
mm path :: String
path@(String -> String
takeExtension -> String
".hs") = case [String]
pathParts of
  [] -> ModuleMap
mm
  [String]
_ -> String -> String -> ModuleMap -> ModuleMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
moduleName (String
modulePrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." [String]
pathParts)) ModuleMap
mm
  where
    relativePath :: String
relativePath = (String -> String
takeFileName String
relativeTo) String -> String -> String
</> (String -> String -> String
makeRelative String
relativeTo String
path)
    pathParts :: [String]
pathParts = String -> [String]
splitDirectories (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
relativePath
    baseModuleName :: String
baseModuleName = [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
pathParts
    moduleName :: String
moduleName = case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
doesNotExist (String
baseModuleName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
baseModuleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n | Integer
n <- [(Integer
1 :: Integer)..]]) of
      (String
x:[String]
_) -> String
x
      [String]
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"Impossible"
    doesNotExist :: String -> Bool
doesNotExist String
x = Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (String -> ModuleMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
x ModuleMap
mm)
addModuleToMap String
_ String
_ ModuleMap
mm String
_ = ModuleMap
mm

-- | From https://stackoverflow.com/a/51713361/2659595
traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b
traverseDir :: forall b.
(String -> Bool) -> (b -> String -> IO b) -> b -> String -> IO b
traverseDir String -> Bool
validDir b -> String -> IO b
transition =
  let go :: b -> String -> IO b
go b
state String
dirPath = do
        [String]
names <- String -> IO [String]
listDirectory String
dirPath
        let paths :: [String]
paths = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dirPath String -> String -> String
</>) [String]
names
        ([String]
dirPaths, [String]
filePaths) <- (String -> IO Bool) -> [String] -> IO ([String], [String])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM String -> IO Bool
doesDirectoryExist [String]
paths
        b
state' <- (b -> String -> IO b) -> b -> [String] -> IO b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM b -> String -> IO b
transition b
state [String]
filePaths
        (b -> String -> IO b) -> b -> [String] -> IO b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM b -> String -> IO b
go b
state' ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
validDir [String]
dirPaths)
 in b -> String -> IO b
go

-- | From https://hackage.haskell.org/package/extra-1.7.9/docs/src/Control.Monad.Extra.html#partitionM
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
_ [] = ([a], [a]) -> m ([a], [a])
forall a. a -> m 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 a. a -> m 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)