diff --git a/src/plugins/System/Plugins/Load.hs b/src/plugins/System/Plugins/Load.hs
index 19fb54f..c919af1 100644
--- a/src/plugins/System/Plugins/Load.hs
+++ b/src/plugins/System/Plugins/Load.hs
@@ -27,8 +27,6 @@ module System.Plugins.Load (
, pdynload , pdynload_
, unload
, unloadAll
- , hasChanged
- , hasChanged'
, reload
, Module(..)
@@ -74,7 +72,6 @@ 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
@@ -311,86 +308,7 @@ unloadAll m = do moduleDeps <- getModuleDeps 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 modFile <- doesFileExist p
- mbFile <- findFile suffices p
- case mbFile of
- Just f | modFile
- -> 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)
- _ -> return False
- 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
diff --git a/src/plugins/System/Plugins/Make.hs b/src/plugins/System/Plugins/Make.hs
index 278df39..251cb15 100644
--- a/src/plugins/System/Plugins/Make.hs
+++ b/src/plugins/System/Plugins/Make.hs
@@ -20,6 +20,11 @@
module System.Plugins.Make (
+ hasChanged,
+ hasChanged',
+ recompileAll,
+ recompileAll',
+
make,
makeAll,
makeWith,
@@ -41,11 +46,19 @@ module System.Plugins.Make (
import System.Plugins.Utils
import System.Plugins.Parser
+import System.Plugins.LoadTypes ( Module (Module, path) )
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
-import System.Plugins.Env ( lookupMerged, addMerge )
+import System.Plugins.Env ( lookupMerged, addMerge
+ , getModuleDeps)
-import System.IO
-import System.Directory ( doesFileExist, removeFile )
+#if DEBUG
+import System.IO (hFlush, stdout, openFile, IOMode(..),hClose, hPutStr)
+#else
+import System.IO (openFile, IOMode(..),hClose,hPutStr)
+#endif
+
+import System.Directory ( doesFileExist, removeFile
+ , getModificationTime )
import Control.Exception ( handleJust )
import GHC.IOBase ( Exception(IOException) )
@@ -54,6 +67,7 @@ import GHC.IOBase ( Exception(IOException) )
import System.IO.Error ( isDoesNotExistError )
#endif
+
------------------------------------------------------------------------
--
-- A better compiler status.
@@ -80,6 +94,46 @@ type MergeCode = MakeCode
type Args = [Arg]
type Errors = [String]
+--
+-- |Returns @True@ if the module or any of its dependencies have older object files than source files.
+-- Defaults to @True@ if some files couldn't be located.
+--
+hasChanged :: Module -> IO Bool
+hasChanged = hasChanged' ["hs","lhs"]
+
+hasChanged' :: [String] -> Module -> IO Bool
+hasChanged' suffices m@(Module {path = p})
+ = do modFile <- doesFileExist p
+ mbFile <- findFile suffices p
+ case mbFile of
+ Just f | modFile
+ -> 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)
+ _ -> return True
+
+--
+-- |Like 'makeAll' but with better recompilation checks since module dependencies are known.
+--
+recompileAll :: Module -> [Arg] -> IO MakeStatus
+recompileAll = recompileAll' ["hs","lhs"]
+
+recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus
+recompileAll' suffices m args
+ = do changed <- hasChanged m
+ if not changed
+ then do mbSource <- findFile suffices (path m)
+ case mbSource of
+ Nothing
+ -> error $ "Couldn't find source for object file: " ++ path m
+ Just source
+ -> makeAll source args
+ else return (MakeSuccess NotReq (path m))
+
-- ---------------------------------------------------------------------
-- | Standard make. Compile a single module, unconditionally.
-- Behaves like ghc -c
diff --git a/src/plugins/System/Plugins/Utils.hs b/src/plugins/System/Plugins/Utils.hs
index 09f3bf1..c034f76 100644
--- a/src/plugins/System/Plugins/Utils.hs
+++ b/src/plugins/System/Plugins/Utils.hs
@@ -30,13 +30,18 @@ module System.Plugins.Utils (
mkUniqueIn,
hMkUniqueIn,
+ findFile,
+
mkTemp, mkTempIn, {- internal -}
replaceSuffix,
outFilePath,
dropSuffix,
mkModid,
-
+ changeFileExt,
+ joinFileExt,
+ splitFileExt,
+
isSublistOf, -- :: Eq a => [a] -> [a] -> Bool
dirname,
@@ -167,6 +172,16 @@ hMkUniqueIn dir = do (t,h) <- mkTempIn dir
then hClose h >> removeFile t >> hMkUniqueIn dir
else return (t,h)
+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
+
+
+
-- ---------------------------------------------------------------------
--
-- | execute a command and it's arguments, returning the
@@ -250,6 +265,66 @@ dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f
mkModid :: String -> String
mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (/= '/')) . reverse
+
+-----------------------------------------------------------
+-- Code from Cabal ----------------------------------------
+
+-- | 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
+
+-- Code from Cabal end ------------------------------------
+-----------------------------------------------------------
+
+
-- | return the object file, given the .conf file
-- i.e. /home/dons/foo.rc -> /home/dons/foo.o
--