module Distribution.HaskellSuite.Modules
(
ModuleT
, getModuleInfo
, evalModuleT
, runModuleT
, MonadModule(..)
, ModName(..)
, convertModuleName
) where
import Distribution.HaskellSuite.Packages
import Distribution.Simple.Utils
import Distribution.InstalledPackageInfo
import Distribution.Text
import Distribution.ModuleName
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Cont
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Writer
import Data.List
import qualified Data.Map as Map
import System.FilePath
class Monad m => MonadModule m where
type ModuleInfo m
lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))
insertInCache :: ModName n => n -> ModuleInfo m -> m ()
getPackages :: m Packages
readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)
class ModName n where
modToString :: n -> String
instance ModName String where
modToString = id
instance ModName ModuleName where
modToString = display
convertModuleName :: (ModName n) => n -> ModuleName
convertModuleName = fromString . modToString
getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))
getModuleInfo name = do
cached <- lookupInCache name
case cached of
Just i -> return $ Just i
Nothing -> do
pkgs <- getPackages
case findModule'sPackage pkgs name of
Nothing -> return Nothing
Just pkg -> do
i <- readModuleInfo (libraryDirs pkg) name
insertInCache name i
return $ Just i
findModule'sPackage :: ModName n => Packages -> n -> Maybe InstalledPackageInfo
findModule'sPackage pkgs m = find ((convertModuleName m `elem`) . exposedModules) pkgs
newtype ModuleT i m a =
ModuleT { unModuleT ::
(StateT (Map.Map ModuleName i)
(ReaderT (Packages, [FilePath] -> ModuleName -> m i) m)
a)
}
deriving (Functor, Applicative, Monad)
instance MonadTrans (ModuleT i) where
lift = ModuleT . lift . lift
instance MonadIO m => MonadIO (ModuleT i m) where
liftIO = ModuleT . liftIO
instance (Functor m, Monad m) => MonadModule (ModuleT i m) where
type ModuleInfo (ModuleT i m) = i
lookupInCache n = ModuleT $ Map.lookup (convertModuleName n) <$> get
insertInCache n i = ModuleT $ modify $ Map.insert (convertModuleName n) i
getPackages = ModuleT $ asks fst
readModuleInfo dirs mod =
lift =<< ModuleT (asks snd) <*> pure dirs <*> pure (convertModuleName mod)
mapModuleT :: Monad m => (m a -> m b) -> ModuleT i m a -> ModuleT i m b
mapModuleT f m = ModuleT $ mapStateT (mapReaderT f') (unModuleT m)
where
f' ma = do
(a,c) <- ma
b <- f (return a)
return (b,c)
instance MonadReader r m => MonadReader r (ModuleT i m) where
ask = lift ask
local = mapModuleT . local
reader = lift . reader
instance MonadState s m => MonadState s (ModuleT i m) where
get = lift get
put = lift . put
state = lift . state
deriving instance MonadWriter w m => MonadWriter w (ModuleT i m)
deriving instance MonadError e m => MonadError e (ModuleT i m)
deriving instance MonadCont m => MonadCont (ModuleT i m)
runModuleT
:: MonadIO m
=> ModuleT i m a
-> Packages
-> String
-> (FilePath -> m i)
-> Map.Map ModuleName i
-> m (a, Map.Map ModuleName i)
runModuleT (ModuleT a) pkgs suffix readInfo modMap =
runReaderT (runStateT a modMap) (pkgs, findAndReadInfo)
where
findAndReadInfo dirs name = do
(base, rel) <- liftIO $ findModuleFile dirs [suffix] name
readInfo $ base </> rel
evalModuleT
:: MonadIO m
=> ModuleT i m a
-> Packages
-> String
-> (FilePath -> m i)
-> m a
evalModuleT a pkgs suffix readInfo =
fst `liftM` runModuleT a pkgs suffix readInfo Map.empty