Hacked System.Plugins.Make.recompileAll and a bit of refactoring.
Moved 'hasChanged' to System.Plugins.Make and moved the FilePath utilities to System.Plugins.Utils.
This commit is contained in:
parent
36fa0c6433
commit
463b96f190
@ -27,8 +27,6 @@ module System.Plugins.Load (
|
|||||||
, pdynload , pdynload_
|
, pdynload , pdynload_
|
||||||
, unload
|
, unload
|
||||||
, unloadAll
|
, unloadAll
|
||||||
, hasChanged
|
|
||||||
, hasChanged'
|
|
||||||
, reload
|
, reload
|
||||||
, Module(..)
|
, Module(..)
|
||||||
|
|
||||||
@ -74,7 +72,6 @@ import GHC.Prim ( unsafeCoerce# )
|
|||||||
import System.IO ( hFlush, stdout )
|
import System.IO ( hFlush, stdout )
|
||||||
#endif
|
#endif
|
||||||
import System.IO ( hClose )
|
import System.IO ( hClose )
|
||||||
import System.Directory ( getModificationTime )
|
|
||||||
|
|
||||||
-- TODO need a loadPackage p package.conf :: IO () primitive
|
-- TODO need a loadPackage p package.conf :: IO () primitive
|
||||||
|
|
||||||
@ -311,86 +308,7 @@ unloadAll m = do moduleDeps <- getModuleDeps m
|
|||||||
mapM_ unloadAll moduleDeps
|
mapM_ unloadAll moduleDeps
|
||||||
unload m
|
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
|
-- | this will be nice for panTHeon, needs thinking about the interface
|
||||||
-- reload a single object file. don't care about depends, assume they
|
-- reload a single object file. don't care about depends, assume they
|
||||||
|
@ -20,6 +20,11 @@
|
|||||||
|
|
||||||
module System.Plugins.Make (
|
module System.Plugins.Make (
|
||||||
|
|
||||||
|
hasChanged,
|
||||||
|
hasChanged',
|
||||||
|
recompileAll,
|
||||||
|
recompileAll',
|
||||||
|
|
||||||
make,
|
make,
|
||||||
makeAll,
|
makeAll,
|
||||||
makeWith,
|
makeWith,
|
||||||
@ -41,11 +46,19 @@ module System.Plugins.Make (
|
|||||||
|
|
||||||
import System.Plugins.Utils
|
import System.Plugins.Utils
|
||||||
import System.Plugins.Parser
|
import System.Plugins.Parser
|
||||||
|
import System.Plugins.LoadTypes ( Module (Module, path) )
|
||||||
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
|
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
|
||||||
import System.Plugins.Env ( lookupMerged, addMerge )
|
import System.Plugins.Env ( lookupMerged, addMerge
|
||||||
|
, getModuleDeps)
|
||||||
|
|
||||||
import System.IO
|
#if DEBUG
|
||||||
import System.Directory ( doesFileExist, removeFile )
|
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 Control.Exception ( handleJust )
|
||||||
import GHC.IOBase ( Exception(IOException) )
|
import GHC.IOBase ( Exception(IOException) )
|
||||||
@ -54,6 +67,7 @@ import GHC.IOBase ( Exception(IOException) )
|
|||||||
import System.IO.Error ( isDoesNotExistError )
|
import System.IO.Error ( isDoesNotExistError )
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------------------
|
------------------------------------------------------------------------
|
||||||
--
|
--
|
||||||
-- A better compiler status.
|
-- A better compiler status.
|
||||||
@ -80,6 +94,46 @@ type MergeCode = MakeCode
|
|||||||
type Args = [Arg]
|
type Args = [Arg]
|
||||||
type Errors = [String]
|
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.
|
-- | Standard make. Compile a single module, unconditionally.
|
||||||
-- Behaves like ghc -c
|
-- Behaves like ghc -c
|
||||||
|
@ -30,12 +30,17 @@ module System.Plugins.Utils (
|
|||||||
mkUniqueIn,
|
mkUniqueIn,
|
||||||
hMkUniqueIn,
|
hMkUniqueIn,
|
||||||
|
|
||||||
|
findFile,
|
||||||
|
|
||||||
mkTemp, mkTempIn, {- internal -}
|
mkTemp, mkTempIn, {- internal -}
|
||||||
|
|
||||||
replaceSuffix,
|
replaceSuffix,
|
||||||
outFilePath,
|
outFilePath,
|
||||||
dropSuffix,
|
dropSuffix,
|
||||||
mkModid,
|
mkModid,
|
||||||
|
changeFileExt,
|
||||||
|
joinFileExt,
|
||||||
|
splitFileExt,
|
||||||
|
|
||||||
isSublistOf, -- :: Eq a => [a] -> [a] -> Bool
|
isSublistOf, -- :: Eq a => [a] -> [a] -> Bool
|
||||||
|
|
||||||
@ -167,6 +172,16 @@ hMkUniqueIn dir = do (t,h) <- mkTempIn dir
|
|||||||
then hClose h >> removeFile t >> hMkUniqueIn dir
|
then hClose h >> removeFile t >> hMkUniqueIn dir
|
||||||
else return (t,h)
|
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
|
-- | execute a command and it's arguments, returning the
|
||||||
@ -250,6 +265,66 @@ dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f
|
|||||||
mkModid :: String -> String
|
mkModid :: String -> String
|
||||||
mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (/= '/')) . reverse
|
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
|
-- | return the object file, given the .conf file
|
||||||
-- i.e. /home/dons/foo.rc -> /home/dons/foo.o
|
-- i.e. /home/dons/foo.rc -> /home/dons/foo.o
|
||||||
--
|
--
|
||||||
|
Loading…
x
Reference in New Issue
Block a user