Recursive modification checker.

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 :: Module -> IO [Module]
-getModuleDeps m = withDepEnv env $ \fm -> return $ lookupFM fm m
+getModuleDeps m = withDepEnv env $ \fm -> return $ fromMaybe [] (lookupFM fm m)
 
 
 --

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