some minor haddock improvements and removal of trailing whitespace

This commit is contained in:
Jeremy Shaw 2012-10-22 19:46:51 +00:00
parent 682a2dcbf2
commit 709114d1ec

View File

@ -3,23 +3,23 @@
{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ForeignFunctionInterface #-}
-- --
-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (C) 2004-5 Don Stewart
-- --
-- This library is free software; you can redistribute it and/or -- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public -- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either -- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version. -- version 2.1 of the License, or (at your option) any later version.
-- --
-- This library is distributed in the hope that it will be useful, -- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details. -- Lesser General Public License for more details.
-- --
-- You should have received a copy of the GNU Lesser General Public -- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software -- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA -- USA
-- --
-- | An interface to the GHC runtime's dynamic linker, providing runtime -- | An interface to the GHC runtime's dynamic linker, providing runtime
-- loading and linking of Haskell object files, commonly known as -- loading and linking of Haskell object files, commonly known as
@ -34,7 +34,7 @@ module System.Plugins.Load (
, load , load
, load_ , load_
, dynload , dynload
, pdynload , pdynload
, pdynload_ , pdynload_
, unload , unload
, unloadAll , unloadAll
@ -149,7 +149,7 @@ data LoadStatus a
-- provided with appropriate type constraints such that Haskell compiler -- provided with appropriate type constraints such that Haskell compiler
-- can determine the expected type returned by 'load', as the return -- can determine the expected type returned by 'load', as the return
-- type is notionally polymorphic. -- type is notionally polymorphic.
-- --
-- Example: -- Example:
-- --
-- > do mv <- load "Plugin.o" ["api"] [] "resource" -- > do mv <- load "Plugin.o" ["api"] [] "resource"
@ -184,18 +184,21 @@ load obj incpaths pkgconfs sym = do
#endif #endif
addModuleDeps m' moduleDeps addModuleDeps m' moduleDeps
v <- loadFunction m sym v <- loadFunction m sym
return $ case v of return $ case v of
Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"]
Just a -> LoadSuccess m a Just a -> LoadSuccess m a
-- --
-- | Like load, but doesn't want a package.conf arg (they are rarely used) -- | Like load, but doesn't want a package.conf arg (they are rarely used)
-- --
load_ :: FilePath -> [FilePath] -> Symbol -> IO (LoadStatus a) load_ :: FilePath -- ^ object file
-> [FilePath] -- ^ any include paths
-> Symbol -- ^ symbol to find
-> IO (LoadStatus a)
load_ o i s = load o i [] s load_ o i s = load o i [] s
--
-- A work-around for Dynamics. The keys used to compare two TypeReps are -- | A work-around for Dynamics. The keys used to compare two TypeReps are
-- somehow not equal for the same type in hs-plugin's loaded objects. -- somehow not equal for the same type in hs-plugin's loaded objects.
-- Solution: implement our own dynamics... -- Solution: implement our own dynamics...
-- --
@ -204,8 +207,8 @@ load_ o i s = load o i [] s
-- is not the case, we core dump. Use pdynload if you don't trust the -- is not the case, we core dump. Use pdynload if you don't trust the
-- user to supply you with a Dynamic -- user to supply you with a Dynamic
-- --
dynload :: Typeable a dynload :: Typeable a
=> FilePath => FilePath
-> [FilePath] -> [FilePath]
-> [PackageConf] -> [PackageConf]
-> Symbol -> Symbol
@ -220,7 +223,8 @@ dynload obj incpaths pkgconfs sym = do
Nothing -> LoadFailure ["Mismatched types in interface"] Nothing -> LoadFailure ["Mismatched types in interface"]
------------------------------------------------------------------------ ------------------------------------------------------------------------
--
-- |
-- The super-replacement for dynload -- The super-replacement for dynload
-- --
-- Use GHC at runtime so we get staged type inference, providing full -- Use GHC at runtime so we get staged type inference, providing full
@ -229,7 +233,6 @@ dynload obj incpaths pkgconfs sym = do
-- --
-- TODO where does the .hc file go in the call to build() ? -- TODO where does the .hc file go in the call to build() ?
-- --
pdynload :: FilePath -- ^ object to load pdynload :: FilePath -- ^ object to load
-> [FilePath] -- ^ include paths -> [FilePath] -- ^ include paths
-> [PackageConf] -- ^ package confs -> [PackageConf] -- ^ package confs
@ -237,7 +240,7 @@ pdynload :: FilePath -- ^ object to load
-> Symbol -- ^ symbol -> Symbol -- ^ symbol
-> IO (LoadStatus a) -> IO (LoadStatus a)
pdynload object incpaths pkgconfs ty sym = do pdynload object incpaths pkgconfs ty sym = do
#if DEBUG #if DEBUG
putStr "Checking types ... " >> hFlush stdout putStr "Checking types ... " >> hFlush stdout
#endif #endif
@ -245,7 +248,7 @@ pdynload object incpaths pkgconfs ty sym = do
#if DEBUG #if DEBUG
putStrLn "done" putStrLn "done"
#endif #endif
if null errors if null errors
then load object incpaths pkgconfs sym then load object incpaths pkgconfs sym
else return $ LoadFailure errors else return $ LoadFailure errors
@ -269,12 +272,12 @@ pdynload_ object incpaths pkgconfs args ty sym = do
#if DEBUG #if DEBUG
putStrLn "done" putStrLn "done"
#endif #endif
if null errors if null errors
then load object incpaths pkgconfs sym then load object incpaths pkgconfs sym
else return $ LoadFailure errors else return $ LoadFailure errors
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- run the typechecker over the constraint file -- | run the typechecker over the constraint file
-- --
-- Problem: if the user depends on a non-auto package to build the -- Problem: if the user depends on a non-auto package to build the
-- module, then that package will not be in scope when we try to build -- module, then that package will not be in scope when we try to build
@ -290,7 +293,7 @@ unify obj incs args ty sym = do
(tmpf1,hdl1) <- mkTemp -- and send .hi file here. (tmpf1,hdl1) <- mkTemp -- and send .hi file here.
hClose hdl1 hClose hdl1
let nm = mkModid (basename tmpf) let nm = mkModid (basename tmpf)
src = mkTest nm (hierize' . mkModid . hierize $ obj) src = mkTest nm (hierize' . mkModid . hierize $ obj)
(fst $ break (=='.') ty) ty sym (fst $ break (=='.') ty) ty sym
is = map ("-i"++) incs -- api is = map ("-i"++) incs -- api
@ -312,7 +315,7 @@ unify obj incs args ty sym = do
hierize' ('\\':cs) = '.' : hierize' cs hierize' ('\\':cs) = '.' : hierize' cs
hierize' (c:cs) = c : hierize' cs hierize' (c:cs) = c : hierize' cs
mkTest modnm plugin api ty sym = mkTest modnm plugin api ty sym =
"module "++ modnm ++" where" ++ "module "++ modnm ++" where" ++
"\nimport qualified " ++ plugin ++ "\nimport qualified " ++ plugin ++
"\nimport qualified " ++ api ++ "\nimport qualified " ++ api ++
@ -327,11 +330,11 @@ mkTest modnm plugin api ty sym =
pdynload obj incpaths pkgconfs sym ty = do pdynload obj incpaths pkgconfs sym ty = do
(m, v) <- load obj incpaths pkgconfs sym (m, v) <- load obj incpaths pkgconfs sym
ty' <- mungeIface sym obj ty' <- mungeIface sym obj
if ty == ty' if ty == ty'
then return $ Just (m, v) then return $ Just (m, v)
else return Nothing -- mismatched types else return Nothing -- mismatched types
where where
-- grab the iface output from GHC. find the line relevant to our -- grab the iface output from GHC. find the line relevant to our
-- symbol. grab the string rep of the type. -- symbol. grab the string rep of the type.
mungeIface sym o = do mungeIface sym o = do
@ -348,11 +351,11 @@ pdynload obj incpaths pkgconfs sym ty = do
-- --
-- a version of load the also unwraps and types a Dynamic object -- a version of load the also unwraps and types a Dynamic object
-- --
dynload2 :: Typeable a => dynload2 :: Typeable a =>
FilePath -> FilePath ->
FilePath -> FilePath ->
Maybe [PackageConf] -> Maybe [PackageConf] ->
Symbol -> Symbol ->
IO (Module, a) IO (Module, a)
dynload2 obj incpath pkgconfs sym = do dynload2 obj incpath pkgconfs sym = do
@ -402,13 +405,13 @@ reload m@(Module{path = p, iface = hi}) sym = do
#endif #endif
m_ <- loadObject p . Object . ifaceModuleName $ hi -- load object at path p m_ <- loadObject p . Object . ifaceModuleName $ hi -- load object at path p
let m' = m_ { iface = hi } let m' = m_ { iface = hi }
resolveObjs (unloadAll m) resolveObjs (unloadAll m)
#if DEBUG #if DEBUG
putStrLn "done" >> hFlush stdout putStrLn "done" >> hFlush stdout
#endif #endif
v <- loadFunction m' sym v <- loadFunction m' sym
return $ case v of return $ case v of
Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"]
Just a -> LoadSuccess m' a Just a -> LoadSuccess m' a
@ -493,31 +496,29 @@ loadPackageFunction pkgName modName functionName =
-- NB the environment stores the *full path* to an object. So if you -- NB the environment stores the *full path* to an object. So if you
-- want to know if a module is already loaded, you need to supply the -- want to know if a module is already loaded, you need to supply the
-- *path* to that object, not the name. -- *path* to that object, not the name.
-- --
-- NB -- let's try just the module name. -- NB -- let's try just the module name.
-- --
-- loadObject loads normal .o objs, and packages too. .o objs come with -- loadObject loads normal .o objs, and packages too. .o objs come with
-- a nice canonical Z-encoded modid. packages just have a simple name. -- a nice canonical Z-encoded modid. packages just have a simple name.
-- Do we want to ensure they won't clash? Probably. -- Do we want to ensure they won't clash? Probably.
-- --
--
-- --
-- the second argument to loadObject is a string to use as the unique -- the second argument to loadObject is a string to use as the unique
-- identifier for this object. For normal .o objects, it should be the -- identifier for this object. For normal .o objects, it should be the
-- Z-encoded modid from the .hi file. For archives\/packages, we can -- Z-encoded modid from the .hi file. For archives\/packages, we can
-- probably get away with the package name -- probably get away with the package name
-- --
loadObject :: FilePath -> Key -> IO Module loadObject :: FilePath -> Key -> IO Module
loadObject p ky@(Object k) = loadObject' p ky k loadObject p ky@(Object k) = loadObject' p ky k
loadObject p ky@(Package k) = loadObject' p ky k loadObject p ky@(Package k) = loadObject' p ky k
loadObject' :: FilePath -> Key -> String -> IO Module loadObject' :: FilePath -> Key -> String -> IO Module
loadObject' p ky k loadObject' p ky k
| ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p) | ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p)
| otherwise | otherwise
= do alreadyLoaded <- isLoaded k = do alreadyLoaded <- isLoaded k
when (not alreadyLoaded) $ do when (not alreadyLoaded) $ do
r <- withCString p c_loadObj r <- withCString p c_loadObj
@ -527,7 +528,7 @@ loadObject' p ky k
where emptyMod q = Module q (mkModid q) Vanilla undefined ky where emptyMod q = Module q (mkModid q) Vanilla undefined ky
-- -- |
-- load a single object. no dependencies. You should know what you're -- load a single object. no dependencies. You should know what you're
-- doing. -- doing.
-- --
@ -560,11 +561,11 @@ resolveObjs unloadLoaded
-- | Unload a module -- | Unload a module
unloadObj :: Module -> IO () unloadObj :: Module -> IO ()
unloadObj (Module { path = p, kind = k, key = ky }) = case k of unloadObj (Module { path = p, kind = k, key = ky }) = case k of
Vanilla -> withCString p $ \c_p -> do Vanilla -> withCString p $ \c_p -> do
removed <- rmModule name removed <- rmModule name
when (removed) $ do r <- c_unloadObj c_p when (removed) $ do r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed") when (not r) (panic "unloadObj: failed")
Shared -> return () -- can't unload .so? Shared -> return () -- can't unload .so?
where name = case ky of Object s -> s ; Package pk -> pk where name = case ky of Object s -> s ; Package pk -> pk
@ -579,14 +580,14 @@ loadShared str = do
putStrLn $ " shared: " ++ str putStrLn $ " shared: " ++ str
#endif #endif
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr if maybe_errmsg == nullPtr
then return (Module str (mkModid str) Shared undefined (Package (mkModid str))) then return (Module str (mkModid str) Shared undefined (Package (mkModid str)))
else do e <- peekCString maybe_errmsg else do e <- peekCString maybe_errmsg
panic $ "loadShared: couldn't load `"++str++"\' because "++e panic $ "loadShared: couldn't load `"++str++"\' because "++e
-- --
-- Load a -package that we might need, implicitly loading the cbits too -- | Load a -package that we might need, implicitly loading the cbits too
-- The argument is the name of package (e.g. \"concurrent\") -- The argument is the name of package (e.g. \"concurrent\")
-- --
-- How to find a package is determined by the package.conf info we store -- How to find a package is determined by the package.conf info we store
@ -610,7 +611,7 @@ loadPackage p = do
-- --
-- Unload a -package, that has already been loaded. Unload the cbits -- | Unload a -package, that has already been loaded. Unload the cbits
-- too. The argument is the name of the package. -- too. The argument is the name of the package.
-- --
-- May need to check if it exists. -- May need to check if it exists.
@ -625,12 +626,12 @@ unloadPackage pkg = do
let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1
libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg) libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg)
flip mapM_ libs $ \p -> withCString p $ \c_p -> do flip mapM_ libs $ \p -> withCString p $ \c_p -> do
r <- c_unloadObj c_p r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed") when (not r) (panic "unloadObj: failed")
rmModule (mkModid p) -- unrecord this module rmModule (mkModid p) -- unrecord this module
-- --
-- load a package using the given package.conf to help -- | load a package using the given package.conf to help
-- TODO should report if it doesn't actually load the package, instead -- TODO should report if it doesn't actually load the package, instead
-- of mapM_ doing nothing like above. -- of mapM_ doing nothing like above.
-- --
@ -644,10 +645,10 @@ loadPackageWith p pkgconfs = do
#if DEBUG #if DEBUG
putStrLn " done" putStrLn " done"
#endif #endif
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
-- module dependency loading -- | module dependency loading
-- --
-- given an Foo.o vanilla object file, supposed to be a plugin compiled -- given an Foo.o vanilla object file, supposed to be a plugin compiled
-- by our library, find the associated .hi file. If this is found, load -- by our library, find the associated .hi file. If this is found, load
@ -684,11 +685,11 @@ loadDepends obj incpaths = do
-- now, try to generate a path to the actual .o file -- now, try to generate a path to the actual .o file
-- fix up hierachical names -- fix up hierachical names
let mods_ = map (\s -> (s, map (\c -> let mods_ = map (\s -> (s, map (\c ->
if c == '.' then '/' else c) $ s)) ds' if c == '.' then '/' else c) $ s)) ds'
-- construct a list of possible dependent modules to load -- construct a list of possible dependent modules to load
let mods = concatMap (\p -> let mods = concatMap (\p ->
map (\(hi,m) -> (hi,p </> m++".o")) mods_) incpaths map (\(hi,m) -> (hi,p </> m++".o")) mods_) incpaths
-- remove modules that don't exist -- remove modules that don't exist
@ -717,15 +718,15 @@ loadDepends obj incpaths = do
#endif #endif
resolveObjs (mapM_ unloadPackage ps') resolveObjs (mapM_ unloadPackage ps')
#if DEBUG #if DEBUG
when (not (null ps')) $ putStrLn "done" when (not (null ps')) $ putStrLn "done"
putStr "Loading object" putStr "Loading object"
mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods'' mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods''
#endif #endif
moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods'' moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods''
return (hiface,moduleDeps) return (hiface,moduleDeps)
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
-- Nice interface to .hi parser -- | Nice interface to .hi parser
-- --
getImports :: String -> IO [String] getImports :: String -> IO [String]
getImports m = do getImports m = do