module Language.Haskell.Modules.SourceDirs
( SourceDirs(..)
, modifyDirs
, withDirs
, RelPath(..)
, PathKey(..)
, APath(..)
, pathKey
#if 0
, pathKey
, pathKeyMaybe
#endif
, Path(..)
, modulePath
, modulePathBase
) where
import Control.Exception.Lifted as IO (catch, throw, bracket)
import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Language.Haskell.Exts.Syntax as S (ModuleName(..))
import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)
import System.FilePath ((<.>), (</>))
class (MonadIO m, MonadBaseControl IO m) => SourceDirs m where
putDirs :: [FilePath] -> m ()
getDirs :: m [FilePath]
modifyDirs :: SourceDirs m => ([FilePath] -> [FilePath]) -> m ()
modifyDirs f = getDirs >>= putDirs . f
withDirs :: SourceDirs m => [FilePath] -> m a -> m a
withDirs dirs action = bracket (getDirs >>= \ save -> putDirs dirs >> return save) putDirs (const action)
newtype PathKey = PathKey {unPathKey :: FilePath} deriving (Eq, Ord, Show)
newtype RelPath = RelPath {unRelPath :: FilePath} deriving (Eq, Ord, Show)
newtype APath = APath {unAPath :: FilePath} deriving (Eq, Ord, Show)
modulePath :: SourceDirs m => String -> S.ModuleName -> m APath
modulePath ext name =
findFile path `IO.catch` (\ (_ :: IOError) -> makePath)
where
makePath =
do dirs <- getDirs
case dirs of
[] -> error "Empty $PATH"
(d : _) -> return . APath $ d </> unRelPath path
path = modulePathBase ext name
modulePathBase :: String -> S.ModuleName -> RelPath
modulePathBase ext (S.ModuleName name) =
RelPath (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
class Path a where
findFileMaybe :: SourceDirs m => a -> m (Maybe APath)
pathKeyMaybe :: SourceDirs m => a -> m (Maybe PathKey)
instance Path RelPath where
findFileMaybe (RelPath path) =
getDirs >>= f
where
f (dir : dirs) =
do let x = dir </> path
exists <- liftIO $ doesFileExist x
if exists then return (Just (APath x)) else f dirs
f [] = return Nothing
pathKeyMaybe path =
findFileMaybe path >>= maybe (return Nothing) (\ (APath path') -> liftIO (canonicalizePath path') >>= return . Just . PathKey)
instance Path PathKey where
findFileMaybe (PathKey x) = return (Just (APath x))
pathKeyMaybe x = return (Just x)
instance Path APath where
findFileMaybe (APath x) =
do exists <- liftIO $ doesFileExist x
return $ if exists then Just (APath x) else Nothing
pathKeyMaybe x =
do mpath <- findFileMaybe x
maybe (return Nothing) (\ (APath x) -> liftIO (canonicalizePath x) >>= return . Just . PathKey) mpath
findFile :: (SourceDirs m, Path p, Show p) => p -> m APath
findFile path =
findFileMaybe path >>=
maybe (do here <- liftIO getCurrentDirectory
dirs <- getDirs
liftIO . throw . userError $ "findFile failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ show path)
return
pathKey :: (SourceDirs m, Path p, Show p) => p -> m PathKey
pathKey path = findFile path >>= liftIO . canonicalizePath . unAPath >>= return . PathKey