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

-- | From https://stackoverflow.com/a/51713361/2659595
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

-- | 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 :: (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)