wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Hacked System.Plugins.Make.recompileAll and a bit of refactoring.

Browse Source 
Moved 'hasChanged' to System.Plugins.Make and
moved the FilePath utilities to System.Plugins.Utils.
This commit is contained in:
lemmih 2005-05-27 11:27:59 +00:00
parent 36fa0c6433
commit 463b96f190
3 changed files with 133 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
src/plugins/System/Plugins/Load.hs
View File

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

60
src/plugins/System/Plugins/Make.hs
View File

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

75
src/plugins/System/Plugins/Utils.hs
View File

@ -30,12 +30,17 @@ module System.Plugins.Utils (
mkUniqueIn,
hMkUniqueIn,
findFile,
mkTemp, mkTempIn, {- internal -}
replaceSuffix,
outFilePath,
dropSuffix,
mkModid,
changeFileExt,
joinFileExt,
splitFileExt,
isSublistOf, -- :: Eq a => [a] -> [a] -> Bool
@ -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
--