module System.Plugins.PathLoader (LoadedModule,
ModuleType (..),
setBasePath,
addDependency,
setDependencies,
delDependency,
delAllDeps,
withDependencies,
loadModule,
unloadModule,
unloadModuleQuiet,
loadFunction,
loadQualifiedFunction,
moduleLoadedAt,
loadedModules,
DL.addDLL) where
import Control.Concurrent.MVar
import Data.List
import qualified Data.HashTable.IO as HT
import Data.Hashable
import Data.IORef
import System.IO.Unsafe
import System.Directory
import Data.Time
import Control.Exception (catch, SomeException)
import System.Plugins.Criteria.LoadCriterion
import System.Plugins.Criteria.UnsafeCriterion
import qualified System.Plugins.DynamicLoader as DL
type Loadable c t t' = (LoadCriterion c t, Effective c t ~ IO t')
data LoadedModule = LM FilePath ModuleType
data ModuleType = MT_Module
| MT_Package
deriving (Eq, Ord, Show)
type ModuleWT = (ModuleType, FilePath)
type PathDynamics = Either DL.DynamicModule DL.DynamicPackage
type PathDep = [ModuleWT]
data PathModule = PM { pm_refc :: !Int,
pm_time :: UTCTime,
pm_deps :: PathDep,
pm_module :: PathDynamics }
type PathEnvData = (Maybe FilePath,
HT.BasicHashTable String [ModuleWT],
HT.BasicHashTable String PathModule)
type PathEnv = (MVar (), IORef PathEnvData)
withPathEnv :: Loadable c t t' => Criterion c t -> PathEnv -> (PathEnvData -> Effective c t) -> Effective c t
withPathEnv _ (mvar, ioref) f
= withMVar mvar (\_ -> readIORef ioref >>= f)
withPathEnvNB :: PathEnv -> (PathEnvData -> IO b) -> IO b
withPathEnvNB (_, ioref) f = readIORef ioref >>= f
modifyPathEnv_ :: PathEnv -> (PathEnvData -> IO PathEnvData) -> IO ()
modifyPathEnv_ (mvar, ioref) f
= withMVar mvar (\_ -> readIORef ioref >>= f >>= writeIORef ioref)
env :: PathEnv
env = unsafePerformIO (do modh <- HT.new
deph <- HT.new
mvar <- newMVar ()
ioref <- newIORef (Nothing, deph, modh)
return (mvar, ioref))
setBasePath :: Maybe FilePath -> IO ()
setBasePath mpath
= modifyPathEnv_ env (\(_, deph, modh) -> return (mpath, deph, modh))
addDependency :: FilePath -> (ModuleType, FilePath) -> IO ()
addDependency from to = withPathEnv UnsafeCriterion env (addDependency' from to)
addDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO ()
addDependency' from to (_, deph, _)
= insertHT_C union deph from [to]
setDependencies :: FilePath -> [(ModuleType, FilePath)] -> IO ()
setDependencies from to = withPathEnv UnsafeCriterion env (setDependencies' from to)
setDependencies' :: FilePath -> [(ModuleType, FilePath)] ->
PathEnvData -> IO ()
setDependencies' from to (_, deph, _)
= insertHT deph from to
delDependency :: FilePath -> (ModuleType, FilePath) -> IO ()
delDependency from to = withPathEnv UnsafeCriterion env (delDependency' from to)
delDependency' :: FilePath -> (ModuleType, FilePath) -> PathEnvData -> IO ()
delDependency' from to (_, deph, _)
= modifyHT (\\[to]) deph from
delAllDeps :: FilePath -> IO ()
delAllDeps from = withPathEnv UnsafeCriterion env (delAllDeps' from)
delAllDeps' :: FilePath -> PathEnvData -> IO ()
delAllDeps' from (_, deph, _)
= deleteHT deph from
withDependencies :: Loadable c t t' => Criterion c t -> FilePath
-> (Maybe [(ModuleType, FilePath)] -> Effective c t) -> Effective c t
withDependencies crit from f
= withPathEnv crit env (\(_,deph,_) -> lookupHT deph from >>= f)
loadModule :: FilePath -> ModuleType -> IO LoadedModule
loadModule m mt
= do withPathEnv UnsafeCriterion env (\env -> do loadModuleWithDep (mt, m) env
DL.resolveFunctions
return (LM m mt))
loadModuleWithDep :: (ModuleType, FilePath) -> PathEnvData -> IO ()
loadModuleWithDep nwt@(_, name) env@(_, _, modh)
= do mpm <- lookupHT modh name
(pm, depmods) <- midLoadModule mpm nwt env
insertHT modh name pm
mapM_ (\modwt -> loadModuleWithDep modwt env) depmods
midLoadModule :: Maybe PathModule -> (ModuleType, FilePath) ->
PathEnvData -> IO (PathModule, PathDep)
midLoadModule (Just pm) _ _ = return $ (pm { pm_refc = pm_refc pm + 1 },
pm_deps pm)
midLoadModule Nothing nwt@(_, name) env@(_, deph, _)
= do (sd, time) <- lowLoadModule nwt env
depmods <- lookupDefHT deph [] name
return (PM 1 time depmods sd, depmods)
lowLoadModule :: ModuleWT -> PathEnvData -> IO (PathDynamics, UTCTime)
lowLoadModule (MT_Package, name) (_, _, _)
= do lp <- DL.loadPackageFromPath name
time <- getModificationTime (DL.dp_path lp)
return (Right lp, time)
lowLoadModule (MT_Module, name) (mpath, _, _)
= do lm <- DL.loadModuleFromPath name mpath
time <- getModificationTime (DL.dm_path lm)
return (Left lm, time)
unloadModule :: LoadedModule -> IO ()
unloadModule (LM name _)
= withPathEnv UnsafeCriterion env (unloadModuleWithDep name)
unloadModuleQuiet :: LoadedModule -> IO ()
unloadModuleQuiet (LM name _)
= withPathEnv UnsafeCriterion env (\env -> catch (unloadModuleWithDep name env)
(\(_ :: SomeException) -> return ()))
unloadModuleWithDep :: FilePath -> PathEnvData -> IO ()
unloadModuleWithDep name env@(_, _, modh)
= do mpm <- lookupHT modh name
pm <- maybe (fail $ "Module " ++ name ++ " not loaded")
return mpm
if pm_refc pm > 1
then do insertHT modh name (pm { pm_refc = pm_refc pm 1 })
else do lowUnloadModule (pm_module pm)
deleteHT modh name
mapM_ (\(_, m) -> unloadModuleWithDep m env) (pm_deps pm)
lowUnloadModule :: PathDynamics -> IO ()
lowUnloadModule (Left lm) = DL.unloadModule lm
lowUnloadModule (Right lp) = DL.unloadPackage lp
loadFunction :: Loadable c t t' => Criterion c t -> LoadedModule -> String -> Effective c t
loadFunction crit (LM m MT_Module) name
= withPathEnv crit env (loadFunction' m name)
where loadFunction' mname fname (_, _, modh)
= do mpm <- HT.lookup modh mname
pm <- maybe (fail $ "Module " ++ mname ++ " isn't loaded")
return mpm
let Left dm = pm_module pm
DL.loadFunction dm fname
loadFunction _ _ _ = fail "You cannot load functions from a package."
loadQualifiedFunction :: Loadable c t t' => Criterion c t -> String -> Effective c t
loadQualifiedFunction crit name
= withPathEnv crit env (loadQualifiedFunction' name)
where loadQualifiedFunction' qname _ = DL.loadQualifiedFunction qname
moduleLoadedAt :: LoadedModule -> IO UTCTime
moduleLoadedAt (LM m _)
= withPathEnvNB env (moduleLoadedAt' m)
moduleLoadedAt' :: FilePath -> PathEnvData -> IO UTCTime
moduleLoadedAt' name (_, _, modh)
= do mpm <- HT.lookup modh name
pm <- maybe (fail $ "Module " ++ name ++ " not loaded")
return mpm
return (pm_time pm)
loadedModules :: IO [String]
loadedModules = withPathEnvNB env loadedModules'
loadedModules' :: PathEnvData -> IO [String]
loadedModules' (_, _, modh) = HT.toList modh >>= (\lst -> return (map fst lst))
insertHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> val -> IO ()
insertHT ht key val
= do HT.delete ht key
HT.insert ht key val
insertHT_C :: (Eq key, Hashable key) => (val -> val -> val) -> HT.BasicHashTable key val -> key -> val -> IO ()
insertHT_C func ht key val
= do mval <- HT.lookup ht key
case mval of
Just val' -> insertHT ht key (func val val')
Nothing -> insertHT ht key val
modifyHT :: (Eq key, Hashable key) => (val -> val) -> HT.BasicHashTable key val -> key -> IO ()
modifyHT func ht key
= do mval <- HT.lookup ht key
case mval of
Just val -> insertHT ht key (func val)
Nothing -> return ()
lookupHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO (Maybe val)
lookupHT ht key = HT.lookup ht key
deleteHT :: (Eq key, Hashable key) => HT.BasicHashTable key val -> key -> IO ()
deleteHT ht key = HT.delete ht key
lookupDefHT :: (Eq key, Hashable key) => HT.BasicHashTable key b -> b -> key -> IO b
lookupDefHT ht val key
= do mval <- HT.lookup ht key
case mval of
Just val -> return val
Nothing -> return val