{-# 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


-- 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 = forall b.
(String -> Bool) -> (b -> String -> IO b) -> b -> String -> IO b
traverseDir (forall a b. a -> b -> a
const Bool
True) (\ModuleMap
x String
y -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> ModuleMap -> String -> ModuleMap
addModuleToMap String
baseDir String
modulePrefix ModuleMap
x String
y) 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]
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
moduleName (String
modulePrefix forall a. Semigroup a => a -> a -> a
<> (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 forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
relativePath
    baseModuleName :: String
baseModuleName = forall a. [a] -> a
last [String]
pathParts
    moduleName :: String
moduleName = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
doesNotExist (String
baseModuleName forall a. a -> [a] -> [a]
: [String
baseModuleName forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
n | Integer
n <- [Integer
1..]])
    doesNotExist :: String -> Bool
doesNotExist String
x = forall a. Maybe a -> Bool
isNothing (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 = forall a b. (a -> b) -> [a] -> [b]
map (String
dirPath String -> String -> String
</>) [String]
names
        ([String]
dirPaths, [String]
filePaths) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM String -> IO Bool
doesDirectoryExist [String]
paths
        b
state' <- 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
        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' (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
_ [] = 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) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
x | Bool
res]forall a. [a] -> [a] -> [a]
++[a]
as, [a
x | Bool -> Bool
not Bool
res]forall a. [a] -> [a] -> [a]
++[a]
bs)