Recursive modification checker.
This commit is contained in:
parent
491477aeac
commit
81d13a4e8c
@ -58,7 +58,7 @@ import System.Plugins.ParsePkgConfLite ( parsePkgConf )
|
||||
import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix )
|
||||
|
||||
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
|
||||
import Data.Maybe ( isJust, isNothing )
|
||||
import Data.Maybe ( isJust, isNothing, fromMaybe )
|
||||
import Data.List ( isPrefixOf, nub )
|
||||
|
||||
import System.IO.Unsafe ( unsafePerformIO )
|
||||
@ -247,8 +247,8 @@ addModuleDeps m deps = modifyDepEnv env $ \fm -> return $ addToFM fm m deps
|
||||
--
|
||||
-- Get module dependencies. Nothing if none have been recored.
|
||||
--
|
||||
getModuleDeps :: Module -> IO (Maybe [Module])
|
||||
getModuleDeps m = withDepEnv env $ \fm -> return $ lookupFM fm m
|
||||
getModuleDeps :: Module -> IO [Module]
|
||||
getModuleDeps m = withDepEnv env $ \fm -> return $ fromMaybe [] (lookupFM fm m)
|
||||
|
||||
|
||||
--
|
||||
|
@ -27,6 +27,8 @@ module System.Plugins.Load (
|
||||
, pdynload , pdynload_
|
||||
, unload
|
||||
, unloadAll
|
||||
, hasChanged
|
||||
, hasChanged'
|
||||
, reload
|
||||
, Module(..)
|
||||
|
||||
@ -60,7 +62,6 @@ import AltData.Dynamic ( fromDynamic, Dynamic )
|
||||
import AltData.Typeable ( Typeable )
|
||||
|
||||
import Data.List ( isSuffixOf, nub, nubBy )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Control.Monad ( when, filterM, liftM )
|
||||
import System.Directory ( doesFileExist, removeFile )
|
||||
import Foreign.C.String ( CString, withCString, peekCString )
|
||||
@ -73,6 +74,7 @@ import GHC.Prim ( unsafeCoerce# )
|
||||
import System.IO ( hFlush, stdout )
|
||||
#endif
|
||||
import System.IO ( hClose )
|
||||
import System.Directory ( getModificationTime )
|
||||
|
||||
-- TODO need a loadPackage p package.conf :: IO () primitive
|
||||
|
||||
@ -304,11 +306,89 @@ unload m = rmModuleDeps m >> unloadObj m
|
||||
-- we have the dependencies, so cascaded unloading is possible
|
||||
--
|
||||
unloadAll :: Module -> IO ()
|
||||
unloadAll m = do moduleDeps <- fmap (fromMaybe []) (getModuleDeps m)
|
||||
unloadAll m = do moduleDeps <- getModuleDeps m
|
||||
rmModuleDeps m
|
||||
mapM_ unloadAll moduleDeps
|
||||
unload m
|
||||
|
||||
-- | Changes the extension of a file path.
|
||||
changeFileExt :: FilePath -- ^ The path information to modify.
|
||||
-> String -- ^ The new extension (without a leading period).
|
||||
-- Specify an empty string to remove an existing
|
||||
-- extension from path.
|
||||
-> FilePath -- ^ A string containing the modified path information.
|
||||
changeFileExt fpath ext = joinFileExt name ext
|
||||
where
|
||||
(name,_) = splitFileExt fpath
|
||||
|
||||
-- | The 'joinFileExt' function is the opposite of 'splitFileExt'.
|
||||
-- It joins a file name and an extension to form a complete file path.
|
||||
--
|
||||
-- The general rule is:
|
||||
--
|
||||
-- > filename `joinFileExt` ext == path
|
||||
-- > where
|
||||
-- > (filename,ext) = splitFileExt path
|
||||
joinFileExt :: String -> String -> FilePath
|
||||
joinFileExt fpath "" = fpath
|
||||
joinFileExt fpath ext = fpath ++ '.':ext
|
||||
|
||||
-- | Split the path into file name and extension. If the file doesn\'t have extension,
|
||||
-- the function will return empty string. The extension doesn\'t include a leading period.
|
||||
--
|
||||
-- Examples:
|
||||
--
|
||||
-- > splitFileExt "foo.ext" == ("foo", "ext")
|
||||
-- > splitFileExt "foo" == ("foo", "")
|
||||
-- > splitFileExt "." == (".", "")
|
||||
-- > splitFileExt ".." == ("..", "")
|
||||
-- > splitFileExt "foo.bar."== ("foo.bar.", "")
|
||||
splitFileExt :: FilePath -> (String, String)
|
||||
splitFileExt p =
|
||||
case break (== '.') fname of
|
||||
(suf@(_:_),_:pre) -> (reverse (pre++fpath), reverse suf)
|
||||
_ -> (p, [])
|
||||
where
|
||||
(fname,fpath) = break isPathSeparator (reverse p)
|
||||
|
||||
-- | Checks whether the character is a valid path separator for the host
|
||||
-- platform. The valid character is a 'pathSeparator' but since the Windows
|
||||
-- operating system also accepts a slash (\"\/\") since DOS 2, the function
|
||||
-- checks for it on this platform, too.
|
||||
isPathSeparator :: Char -> Bool
|
||||
isPathSeparator ch =
|
||||
#if defined(CYGWIN) || defined(__MINGW32__)
|
||||
ch == '/' || ch == '\\'
|
||||
#else
|
||||
ch == '/'
|
||||
#endif
|
||||
|
||||
|
||||
--
|
||||
-- |Returns @True@ if the module or any of its dependencies have older object files than source files.
|
||||
--
|
||||
hasChanged :: Module -> IO Bool
|
||||
hasChanged = hasChanged' ["hs","lhs"]
|
||||
|
||||
hasChanged' :: [String] -> Module -> IO Bool
|
||||
hasChanged' suffices m@(Module {path = p})
|
||||
= do mbFile <- findFile suffices p
|
||||
case mbFile of
|
||||
Nothing -> return False
|
||||
Just f -> do srcT <- getModificationTime f
|
||||
objT <- getModificationTime p
|
||||
if srcT > objT
|
||||
then return True
|
||||
else do deps <- getModuleDeps m
|
||||
depsStatus <- mapM (hasChanged' suffices) deps
|
||||
return (or depsStatus)
|
||||
where findFile :: [String] -> FilePath -> IO (Maybe FilePath)
|
||||
findFile [] _ = return Nothing
|
||||
findFile (ext:exts) file
|
||||
= do let l = changeFileExt file ext
|
||||
b <- doesFileExist l
|
||||
if b then return $ Just l
|
||||
else findFile exts file
|
||||
--
|
||||
-- | this will be nice for panTHeon, needs thinking about the interface
|
||||
-- reload a single object file. don't care about depends, assume they
|
||||
|
Loading…
x
Reference in New Issue
Block a user