module Config.Dyre ( wrapMain, Params(..), defaultParams ) where
import System.IO ( hPutStrLn, stderr )
import System.Directory ( doesFileExist, removeFile, canonicalizePath
, getDirectoryContents, doesDirectoryExist )
import System.FilePath ( (</>) )
import System.Environment (getArgs)
import GHC.Environment (getFullArgs)
import Control.Exception (assert)
import Control.Monad ( when, filterM )
import Config.Dyre.Params ( Params(..), RTSOptionHandling(..) )
import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString )
import Config.Dyre.Compat ( customExec )
import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug
, withDyreOptions )
import Config.Dyre.Paths ( getPaths, maybeModTime )
defaultParams :: Params cfgType
defaultParams :: Params cfgType
defaultParams = Params :: forall cfgType.
String
-> Bool
-> Maybe (IO String)
-> Maybe (IO String)
-> (cfgType -> IO ())
-> (cfgType -> String -> cfgType)
-> [String]
-> [String]
-> Bool
-> (String -> IO ())
-> RTSOptionHandling
-> Bool
-> Params cfgType
Params
{ projectName :: String
projectName = String
forall a. HasCallStack => a
undefined
, configCheck :: Bool
configCheck = Bool
True
, configDir :: Maybe (IO String)
configDir = Maybe (IO String)
forall a. Maybe a
Nothing
, cacheDir :: Maybe (IO String)
cacheDir = Maybe (IO String)
forall a. Maybe a
Nothing
, realMain :: cfgType -> IO ()
realMain = cfgType -> IO ()
forall a. HasCallStack => a
undefined
, showError :: cfgType -> String -> cfgType
showError = cfgType -> String -> cfgType
forall a. HasCallStack => a
undefined
, hidePackages :: [String]
hidePackages = []
, ghcOpts :: [String]
ghcOpts = []
, forceRecomp :: Bool
forceRecomp = Bool
True
, statusOut :: String -> IO ()
statusOut = Handle -> String -> IO ()
hPutStrLn Handle
stderr
, rtsOptsHandling :: RTSOptionHandling
rtsOptsHandling = [String] -> RTSOptionHandling
RTSAppend []
, includeCurrentDirectory :: Bool
includeCurrentDirectory = Bool
True
}
wrapMain :: Params cfgType -> cfgType -> IO ()
wrapMain :: Params cfgType -> cfgType -> IO ()
wrapMain params :: Params cfgType
params@Params{projectName :: forall cfgType. Params cfgType -> String
projectName = String
pName} cfg :: cfgType
cfg = Params cfgType -> IO () -> IO ()
forall c a. Params c -> IO a -> IO a
withDyreOptions Params cfgType
params (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Params cfgType -> Bool
forall cfgType. Params cfgType -> Bool
configCheck Params cfgType
params
then Params cfgType -> cfgType -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
realMain Params cfgType
params cfgType
cfg
else do
(thisBinary :: String
thisBinary,tempBinary :: String
tempBinary,configFile :: String
configFile,cacheDir :: String
cacheDir,libsDir :: String
libsDir) <- Params cfgType -> IO (String, String, String, String, String)
forall c. Params c -> IO (String, String, String, String, String)
getPaths Params cfgType
params
[String]
libFiles <- String -> IO [String]
recFiles String
libsDir
[Maybe UTCTime]
libTimes <- (String -> IO (Maybe UTCTime)) -> [String] -> IO [Maybe UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe UTCTime)
maybeModTime [String]
libFiles
Maybe UTCTime
thisTime <- String -> IO (Maybe UTCTime)
maybeModTime String
thisBinary
Maybe UTCTime
tempTime <- String -> IO (Maybe UTCTime)
maybeModTime String
tempBinary
Maybe UTCTime
confTime <- String -> IO (Maybe UTCTime)
maybeModTime String
configFile
let confExists :: Bool
confExists = Maybe UTCTime
confTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe UTCTime
forall a. Maybe a
Nothing
Bool
denyReconf <- IO Bool
getDenyReconf
Bool
forceReconf <- IO Bool
getForceReconf
let needReconf :: Bool
needReconf = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe UTCTime
confTime
, Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe UTCTime
thisTime
, [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> ([Maybe UTCTime] -> [Bool]) -> [Maybe UTCTime] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe UTCTime -> Bool) -> [Maybe UTCTime] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) ([Maybe UTCTime] -> Bool) -> [Maybe UTCTime] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe UTCTime]
libTimes
, Bool
forceReconf
]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
denyReconf Bool -> Bool -> Bool
&& Bool
confExists Bool -> Bool -> Bool
&& Bool
needReconf)
(Params cfgType -> IO ()
forall cfgType. Params cfgType -> IO ()
customCompile Params cfgType
params)
Maybe String
errorData <- Params cfgType -> IO (Maybe String)
forall cfgType. Params cfgType -> IO (Maybe String)
getErrorString Params cfgType
params
Bool
customExists <- String -> IO Bool
doesFileExist String
tempBinary
if Bool
confExists Bool -> Bool -> Bool
&& Bool
customExists
then do
String
thisBinary' <- String -> IO String
canonicalizePath String
thisBinary
String
tempBinary' <- String -> IO String
canonicalizePath String
tempBinary
if String
thisBinary' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
tempBinary'
then Maybe String -> String -> IO ()
forall a. Maybe a -> String -> IO ()
launchSub Maybe String
errorData String
tempBinary
else Maybe String -> IO ()
enterMain Maybe String
errorData
else Maybe String -> IO ()
enterMain Maybe String
errorData
where launchSub :: Maybe a -> String -> IO ()
launchSub errorData :: Maybe a
errorData tempBinary :: String
tempBinary = do
Params cfgType -> String -> IO ()
forall cfgType. Params cfgType -> String -> IO ()
statusOut Params cfgType
params (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Launching custom binary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tempBinary String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
[String]
givenArgs <- RTSOptionHandling -> IO [String]
handleRTSOptions (RTSOptionHandling -> IO [String])
-> RTSOptionHandling -> IO [String]
forall a b. (a -> b) -> a -> b
$ Params cfgType -> RTSOptionHandling
forall cfgType. Params cfgType -> RTSOptionHandling
rtsOptsHandling Params cfgType
params
let arguments :: [String]
arguments = case Maybe a
errorData of
Nothing -> [String]
givenArgs
Just _ -> "--deny-reconf"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
givenArgs
String -> Maybe [String] -> IO ()
customExec String
tempBinary (Maybe [String] -> IO ()) -> Maybe [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
arguments
enterMain :: Maybe String -> IO ()
enterMain errorData :: Maybe String
errorData = do
let mainConfig :: cfgType
mainConfig = case Maybe String
errorData of
Nothing -> cfgType
cfg
Just ed -> Params cfgType -> cfgType -> String -> cfgType
forall cfgType. Params cfgType -> cfgType -> String -> cfgType
showError Params cfgType
params cfgType
cfg String
ed
Params cfgType -> cfgType -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
realMain Params cfgType
params cfgType
mainConfig
recFiles :: FilePath -> IO [FilePath]
recFiles :: String -> IO [String]
recFiles d :: String
d = do
Bool
exists <- String -> IO Bool
doesDirectoryExist String
d
if Bool
exists
then do
[String]
nodes <- String -> IO [String]
getDirectoryContents String
d
let nodes' :: [String]
nodes' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
d String -> String -> String
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
nodes
[String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
nodes'
[String]
dirs <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
nodes'
[String]
subfiles <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
recFiles [String]
dirs
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
subfiles
else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
assertM :: Bool -> m ()
assertM b :: Bool
b = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
filterRTSArgs :: [String] -> [String]
filterRTSArgs = Bool -> [String] -> [String]
filt Bool
False
where
filt :: Bool -> [String] -> [String]
filt _ [] = []
filt _ ("--RTS":rest :: [String]
rest) = []
filt False ("+RTS" :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
True [String]
rest
filt True ("-RTS" :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
filt False (_ :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
filt True (arg :: String
arg :rest :: [String]
rest) = String
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Bool -> [String] -> [String]
filt Bool
True [String]
rest
editRTSOptions :: [String] -> RTSOptionHandling -> [String]
editRTSOptions opts :: [String]
opts (RTSReplace ls :: [String]
ls) = [String]
ls
editRTSOptions opts :: [String]
opts (RTSAppend ls :: [String]
ls) = [String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ls
handleRTSOptions :: RTSOptionHandling -> IO [String]
handleRTSOptions h :: RTSOptionHandling
h = do [String]
fargs <- IO [String]
getFullArgs
[String]
args <- IO [String]
getArgs
let rtsArgs :: [String]
rtsArgs = [String] -> RTSOptionHandling -> [String]
editRTSOptions ([String] -> [String]
filterRTSArgs [String]
fargs) RTSOptionHandling
h
Bool -> IO ()
forall (m :: * -> *). Monad m => Bool -> m ()
assertM (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "--RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
rtsArgs
case [String]
rtsArgs of
[] -> if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "+RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args
then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args
else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ "--RTS"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args
_ -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ["+RTS"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rtsArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--RTS"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args