{-# LANGUAGE CPP #-}
module System.Plugins.Make (
MakeStatus(..),
MakeCode(..),
make,
makeAll,
makeWith,
hasChanged,
hasChanged',
recompileAll,
recompileAll',
MergeStatus(..),
MergeCode,
Args,
Errors,
merge,
mergeTo,
mergeToDir,
makeClean,
makeCleaner,
build,
) where
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.Process ( exec )
import System.Plugins.Env ( lookupMerged, addMerge
, getModuleDeps)
#if DEBUG
import System.IO (hFlush, stdout, openFile, IOMode(..),hClose, hPutStr, hGetContents)
#else
import System.IO (openFile, IOMode(..),hClose,hPutStr, hGetContents)
#endif
import System.Directory ( doesFileExist, removeFile
, getModificationTime )
import Control.Exception ( handleJust )
#if __GLASGOW_HASKELL__ >= 604
import System.IO.Error ( isDoesNotExistError )
#endif
data MakeStatus
= MakeSuccess MakeCode FilePath
| MakeFailure Errors
deriving (MakeStatus -> MakeStatus -> Bool
(MakeStatus -> MakeStatus -> Bool)
-> (MakeStatus -> MakeStatus -> Bool) -> Eq MakeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MakeStatus -> MakeStatus -> Bool
$c/= :: MakeStatus -> MakeStatus -> Bool
== :: MakeStatus -> MakeStatus -> Bool
$c== :: MakeStatus -> MakeStatus -> Bool
Eq,Int -> MakeStatus -> ShowS
[MakeStatus] -> ShowS
MakeStatus -> String
(Int -> MakeStatus -> ShowS)
-> (MakeStatus -> String)
-> ([MakeStatus] -> ShowS)
-> Show MakeStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MakeStatus] -> ShowS
$cshowList :: [MakeStatus] -> ShowS
show :: MakeStatus -> String
$cshow :: MakeStatus -> String
showsPrec :: Int -> MakeStatus -> ShowS
$cshowsPrec :: Int -> MakeStatus -> ShowS
Show)
data MakeCode
= ReComp
| NotReq
deriving (MakeCode -> MakeCode -> Bool
(MakeCode -> MakeCode -> Bool)
-> (MakeCode -> MakeCode -> Bool) -> Eq MakeCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MakeCode -> MakeCode -> Bool
$c/= :: MakeCode -> MakeCode -> Bool
== :: MakeCode -> MakeCode -> Bool
$c== :: MakeCode -> MakeCode -> Bool
Eq,Int -> MakeCode -> ShowS
[MakeCode] -> ShowS
MakeCode -> String
(Int -> MakeCode -> ShowS)
-> (MakeCode -> String) -> ([MakeCode] -> ShowS) -> Show MakeCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MakeCode] -> ShowS
$cshowList :: [MakeCode] -> ShowS
show :: MakeCode -> String
$cshow :: MakeCode -> String
showsPrec :: Int -> MakeCode -> ShowS
$cshowsPrec :: Int -> MakeCode -> ShowS
Show)
data MergeStatus
= MergeSuccess MergeCode Args FilePath
| MergeFailure Errors
deriving (MergeStatus -> MergeStatus -> Bool
(MergeStatus -> MergeStatus -> Bool)
-> (MergeStatus -> MergeStatus -> Bool) -> Eq MergeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MergeStatus -> MergeStatus -> Bool
$c/= :: MergeStatus -> MergeStatus -> Bool
== :: MergeStatus -> MergeStatus -> Bool
$c== :: MergeStatus -> MergeStatus -> Bool
Eq,Int -> MergeStatus -> ShowS
[MergeStatus] -> ShowS
MergeStatus -> String
(Int -> MergeStatus -> ShowS)
-> (MergeStatus -> String)
-> ([MergeStatus] -> ShowS)
-> Show MergeStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MergeStatus] -> ShowS
$cshowList :: [MergeStatus] -> ShowS
show :: MergeStatus -> String
$cshow :: MergeStatus -> String
showsPrec :: Int -> MergeStatus -> ShowS
$cshowsPrec :: Int -> MergeStatus -> ShowS
Show)
type MergeCode = MakeCode
type Args = [Arg]
type Errors = [String]
make :: FilePath -> [Arg] -> IO MakeStatus
make :: String -> [String] -> IO MakeStatus
make String
src [String]
args = String -> [String] -> Bool -> IO MakeStatus
rawMake String
src (String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args) Bool
True
makeAll :: FilePath -> [Arg] -> IO MakeStatus
makeAll :: String -> [String] -> IO MakeStatus
makeAll String
src [String]
args =
String -> [String] -> Bool -> IO MakeStatus
rawMake String
src ( String
"--make"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-no-hs-main"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-v0"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args ) Bool
False
makeWith :: FilePath
-> FilePath
-> [Arg]
-> IO MakeStatus
makeWith :: String -> String -> [String] -> IO MakeStatus
makeWith String
src String
stub [String]
args = do
MergeStatus
status <- String -> String -> IO MergeStatus
merge String
src String
stub
case MergeStatus
status of
MergeFailure [String]
errs -> MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MakeStatus
MakeFailure (String
"merge failed:\n"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
errs)
MergeSuccess MakeCode
_ [String]
args' String
tmpf -> do
MakeStatus
status' <- String -> [String] -> Bool -> IO MakeStatus
rawMake String
tmpf (String
"-c"String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) Bool
True
MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return MakeStatus
status'
hasChanged :: Module -> IO Bool
hasChanged :: Module -> IO Bool
hasChanged = [String] -> Module -> IO Bool
hasChanged' [String
"hs",String
"lhs"]
hasChanged' :: [String] -> Module -> IO Bool
hasChanged' :: [String] -> Module -> IO Bool
hasChanged' [String]
suffices m :: Module
m@(Module {path :: Module -> String
path = String
p})
= do Bool
modFile <- String -> IO Bool
doesFileExist String
p
Maybe String
mbFile <- [String] -> String -> IO (Maybe String)
findFile [String]
suffices String
p
case Maybe String
mbFile of
Just String
f | Bool
modFile
-> do UTCTime
srcT <- String -> IO UTCTime
getModificationTime String
f
UTCTime
objT <- String -> IO UTCTime
getModificationTime String
p
if UTCTime
srcT UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
objT
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do [Module]
deps <- Module -> IO [Module]
getModuleDeps Module
m
[Bool]
depsStatus <- (Module -> IO Bool) -> [Module] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String] -> Module -> IO Bool
hasChanged' [String]
suffices) [Module]
deps
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
depsStatus)
Maybe String
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
recompileAll :: Module -> [Arg] -> IO MakeStatus
recompileAll :: Module -> [String] -> IO MakeStatus
recompileAll = [String] -> Module -> [String] -> IO MakeStatus
recompileAll' [String
"hs",String
"lhs"]
recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus
recompileAll' :: [String] -> Module -> [String] -> IO MakeStatus
recompileAll' [String]
suffices Module
m [String]
args
= do Bool
changed <- Module -> IO Bool
hasChanged Module
m
if Bool
changed
then do Maybe String
mbSource <- [String] -> String -> IO (Maybe String)
findFile [String]
suffices (Module -> String
path Module
m)
case Maybe String
mbSource of
Maybe String
Nothing
-> String -> IO MakeStatus
forall a. HasCallStack => String -> a
error (String -> IO MakeStatus) -> String -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find source for object file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Module -> String
path Module
m
Just String
source
-> String -> [String] -> IO MakeStatus
makeAll String
source [String]
args
else MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
NotReq (Module -> String
path Module
m))
rawMake :: FilePath
-> [Arg]
-> Bool
-> IO MakeStatus
rawMake :: String -> [String] -> Bool -> IO MakeStatus
rawMake String
src [String]
args Bool
docheck = do
Bool
src_exists <- String -> IO Bool
doesFileExist String
src
if Bool -> Bool
not Bool
src_exists
then MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MakeStatus
MakeFailure [String
"Source file does not exist: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
src]
else do {
; let (String
obj,String
_) = String -> [String] -> (String, String)
outFilePath String
src [String]
args
; Bool
src_changed <- if Bool
docheck then String
src String -> String -> IO Bool
`newer` String
obj else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
; if Bool -> Bool
not Bool
src_changed
then MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
NotReq String
obj
else do
#if DEBUG
putStr "Compiling object ... " >> hFlush stdout
#endif
([String]
err, Bool
success) <- String -> String -> [String] -> IO ([String], Bool)
build String
src String
obj [String]
args
#if DEBUG
putStrLn "done"
#endif
MakeStatus -> IO MakeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeStatus -> IO MakeStatus) -> MakeStatus -> IO MakeStatus
forall a b. (a -> b) -> a -> b
$ if Bool
success
then MakeCode -> String -> MakeStatus
MakeSuccess MakeCode
ReComp String
obj
else [String] -> MakeStatus
MakeFailure [String]
err
}
build :: FilePath
-> FilePath
-> [String]
-> IO ([String], Bool)
build :: String -> String -> [String] -> IO ([String], Bool)
build String
src String
obj [String]
extra_opts = do
let odir :: String
odir = ShowS
dirname String
obj
let ghc_opts :: [String]
ghc_opts = [ String
"-O0" ]
output :: [String]
output = [ String
"-o", String
obj, String
"-odir", String
odir,
String
"-hidir", String
odir, String
"-i" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
odir ]
let flags :: [String]
flags = [String]
ghc_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
output [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
src]
#if DEBUG
putStr $ show $ ghc : flags
#endif
([String]
_out,[String]
err,Bool
success) <- String -> [String] -> IO ([String], [String], Bool)
exec String
ghc [String]
flags
Bool
obj_exists <- String -> IO Bool
doesFileExist String
obj
([String], Bool) -> IO ([String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (([String], Bool) -> IO ([String], Bool))
-> ([String], Bool) -> IO ([String], Bool)
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
obj_exists Bool -> Bool -> Bool
&& Bool
success
then ([String
"Compiled, but didn't create object file `"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
objString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"'!"], Bool
success)
else ([String]
err, Bool
success)
merge :: FilePath -> FilePath -> IO MergeStatus
merge :: String -> String -> IO MergeStatus
merge String
src String
stb = do
Maybe String
m_mod <- String -> String -> IO (Maybe String)
lookupMerged String
src String
stb
(String
out,Bool
domerge) <- case Maybe String
m_mod of
Maybe String
Nothing -> do String
out <- IO String
mkUnique
String -> String -> String -> IO ()
addMerge String
src String
stb (ShowS
dropSuffix String
out)
(String, Bool) -> IO (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
out, Bool
True)
Just String
nm -> (String, Bool) -> IO (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Bool) -> IO (String, Bool))
-> (String, Bool) -> IO (String, Bool)
forall a b. (a -> b) -> a -> b
$ (String
nm String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
hsSuf, Bool
False)
String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
domerge
mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeTo :: String -> String -> String -> IO MergeStatus
mergeTo String
src String
stb String
out = String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
False
mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeToDir :: String -> String -> String -> IO MergeStatus
mergeToDir String
src String
stb String
dir = do
String
out <- String -> IO String
mkUniqueIn String
dir
String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
True
rawMerge :: FilePath -> FilePath -> FilePath -> Bool -> IO MergeStatus
rawMerge :: String -> String -> String -> Bool -> IO MergeStatus
rawMerge String
src String
stb String
out Bool
always_merge = do
Bool
src_exists <- String -> IO Bool
doesFileExist String
src
Bool
stb_exists <- String -> IO Bool
doesFileExist String
stb
case () of {()
_
| Bool -> Bool
not Bool
src_exists -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$
[String] -> MergeStatus
MergeFailure [String
"Source file does not exist : "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
src]
| Bool -> Bool
not Bool
stb_exists -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$
[String] -> MergeStatus
MergeFailure [String
"Source file does not exist : "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
stb]
| Bool
otherwise -> do {
;Bool
do_merge <- do Bool
src_changed <- String
src String -> String -> IO Bool
`newer` String
out
Bool
stb_changed <- String
stb String -> String -> IO Bool
`newer` String
out
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
src_changed Bool -> Bool -> Bool
|| Bool
stb_changed
;if Bool -> Bool
not Bool
do_merge Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
always_merge
then MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> [String] -> String -> MergeStatus
MergeSuccess MakeCode
NotReq [] String
out
else do
String
src_str <- String -> IO String
readFile' String
src
String
stb_str <- String -> IO String
readFile' String
stb
let ([String]
a,[String]
a') = String -> ([String], [String])
parsePragmas String
src_str
([String]
b,[String]
b') = String -> ([String], [String])
parsePragmas String
stb_str
opts :: [String]
opts = [String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
a' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b'
let e_src_syn :: Either String HsModule
e_src_syn = String -> String -> Either String HsModule
parse String
src String
src_str
e_stb_syn :: Either String HsModule
e_stb_syn = String -> String -> Either String HsModule
parse String
stb String
stb_str
case (Either String HsModule
e_src_syn,Either String HsModule
e_stb_syn) of
(Left String
e, Either String HsModule
_) -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MergeStatus
MergeFailure [String
e]
(Either String HsModule
_ , Left String
e) -> MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ [String] -> MergeStatus
MergeFailure [String
e]
(Right HsModule
src_syn, Right HsModule
stb_syn) -> do {
;let mrg_syn :: HsModule
mrg_syn = HsModule -> HsModule -> HsModule
mergeModules HsModule
src_syn HsModule
stb_syn
mrg_syn' :: HsModule
mrg_syn'= HsModule -> String -> HsModule
replaceModName HsModule
mrg_syn (ShowS
mkModid ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
basename String
out)
mrg_str :: String
mrg_str = HsModule -> String
pretty HsModule
mrg_syn'
;Handle
hdl <- String -> IOMode -> IO Handle
openFile String
out IOMode
WriteMode
;Handle -> String -> IO ()
hPutStr Handle
hdl String
mrg_str ; Handle -> IO ()
hClose Handle
hdl
;MergeStatus -> IO MergeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (MergeStatus -> IO MergeStatus) -> MergeStatus -> IO MergeStatus
forall a b. (a -> b) -> a -> b
$ MakeCode -> [String] -> String -> MergeStatus
MergeSuccess MakeCode
ReComp [String]
opts String
out
}}}
makeClean :: FilePath -> IO ()
makeClean :: String -> IO ()
makeClean String
f = let f_hi :: String
f_hi = ShowS
dropSuffix String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
hiSuf
f_o :: String
f_o = ShowS
dropSuffix String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
objSuf
in (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
rm_f [String
f_hi, String
f_o]
makeCleaner :: FilePath -> IO ()
makeCleaner :: String -> IO ()
makeCleaner String
f = String -> IO ()
makeClean String
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
rm_f (ShowS
dropSuffix String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
hsSuf)
rm_f :: String -> IO ()
rm_f String
f = (IOError -> Maybe ()) -> (() -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust IOError -> Maybe ()
doesntExist (\()
_->() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> IO ()
removeFile String
f)
where
doesntExist :: IOError -> Maybe ()
doesntExist IOError
ioe
| IOError -> Bool
isDoesNotExistError IOError
ioe = () -> Maybe ()
forall a. a -> Maybe a
Just ()
| Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing
readFile' :: String -> IO String
readFile' String
f = do
Handle
h <- String -> IOMode -> IO Handle
openFile String
f IOMode
ReadMode
String
s <- Handle -> IO String
hGetContents Handle
h
String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Handle -> IO ()
hClose Handle
h
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s