diff --git a/src/plugins/System/Plugins/Env.hs b/src/plugins/System/Plugins/Env.hs index d9743cd..22dca98 100644 --- a/src/plugins/System/Plugins/Env.hs +++ b/src/plugins/System/Plugins/Env.hs @@ -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) -- diff --git a/src/plugins/System/Plugins/Load.hs b/src/plugins/System/Plugins/Load.hs index b3e3954..346e7ee 100644 --- a/src/plugins/System/Plugins/Load.hs +++ b/src/plugins/System/Plugins/Load.hs @@ -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