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 --