module Language.Haskell.Modules.SourceDirs
( SourceDirs(..)
, modifyDirs
, PathKey(..)
, pathKey
, pathKeyMaybe
, modulePath
, modulePathBase
) where
import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw)
import Control.Monad.Trans (liftIO, MonadIO)
import Language.Haskell.Exts.Syntax as S (ModuleName(..))
import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)
import System.FilePath ((<.>), (</>))
class MonadCatchIO m => SourceDirs m where
putDirs :: [FilePath] -> m ()
getDirs :: m [FilePath]
modifyDirs :: SourceDirs m => ([FilePath] -> [FilePath]) -> m ()
modifyDirs f = getDirs >>= putDirs . f
newtype PathKey = PathKey {unPathKey :: FilePath} deriving (Eq, Ord, Show)
pathKey :: SourceDirs m => FilePath -> m PathKey
pathKey path = findFile path >>= liftIO . canonicalizePath >>= return . PathKey
pathKeyMaybe :: SourceDirs m => FilePath -> m (Maybe PathKey)
pathKeyMaybe path = findFileMaybe path >>= maybe (return Nothing) (\ path' -> liftIO (canonicalizePath path') >>= return . Just . PathKey)
modulePath :: SourceDirs m => String -> S.ModuleName -> m FilePath
modulePath ext name =
findFile path `IO.catch` (\ (_ :: IOError) -> makePath)
where
makePath =
do dirs <- getDirs
case dirs of
[] -> return path
(d : _) -> return $ d </> path
path = modulePathBase ext name
modulePathBase :: String -> S.ModuleName -> FilePath
modulePathBase ext (S.ModuleName name) =
base <.> ext
where base = case ext of
"hs" -> map f name
"lhs" -> map f name
"imports" -> name
_ -> error $ "Unsupported extension: " ++ show ext
f '.' = '/'
f c = c
findFile :: SourceDirs m => FilePath -> m FilePath
findFile path =
findFileMaybe path >>=
maybe (do here <- liftIO getCurrentDirectory
dirs <- getDirs
liftIO . throw . userError $ "findFile failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ path)
return
findFileMaybe :: SourceDirs m => FilePath -> m (Maybe FilePath)
findFileMaybe path =
getDirs >>= f
where
f (dir : dirs) =
do let x = dir </> path
exists <- liftIO $ doesFileExist x
if exists then return (Just x) else f dirs
f [] = return Nothing