module Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) where
import Control.Applicative ((<|>))
import Control.Concurrent ( rtsSupportsBoundThreads )
import Control.Monad (when)
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import System.IO ( IOMode(WriteMode), withFile )
import System.Environment (lookupEnv)
import System.Exit ( ExitCode(..) )
import System.Process ( runProcess, waitForProcess )
import System.FilePath
( (</>), dropTrailingPathSeparator, joinPath, splitPath, takeDirectory )
import System.Directory ( getCurrentDirectory, doesFileExist
, createDirectoryIfMissing
, renameFile, removeFile )
import Config.Dyre.Paths ( PathsConfig(..), getPathsConfig, outputExecutable )
import Config.Dyre.Params ( Params(..) )
getErrorPath :: Params cfgType a -> IO FilePath
getErrorPath :: forall cfgType a. Params cfgType a -> IO String
getErrorPath Params cfgType a
params =
(String -> String -> String
</> String
"errors.log") (String -> String)
-> (PathsConfig -> String) -> PathsConfig -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsConfig -> String
cacheDirectory (PathsConfig -> String) -> IO PathsConfig -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Params cfgType a -> IO PathsConfig
forall cfg a. Params cfg a -> IO PathsConfig
getPathsConfig Params cfgType a
params
getErrorString :: Params cfgType a -> IO (Maybe String)
getErrorString :: forall cfgType a. Params cfgType a -> IO (Maybe String)
getErrorString Params cfgType a
params = do
String
errorPath <- Params cfgType a -> IO String
forall cfgType a. Params cfgType a -> IO String
getErrorPath Params cfgType a
params
Bool
errorsExist <- String -> IO Bool
doesFileExist String
errorPath
if Bool -> Bool
not Bool
errorsExist
then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
else do String
errorData <- String -> IO String
readFile String
errorPath
if String
errorData String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
errorData
customCompile :: Params cfgType a -> IO ()
customCompile :: forall cfgType a. Params cfgType a -> IO ()
customCompile params :: Params cfgType a
params@Params{statusOut :: forall cfgType a. Params cfgType a -> String -> IO ()
statusOut = String -> IO ()
output} = do
PathsConfig
paths <- Params cfgType a -> IO PathsConfig
forall cfg a. Params cfg a -> IO PathsConfig
getPathsConfig Params cfgType a
params
let
tempBinary :: String
tempBinary = PathsConfig -> String
customExecutable PathsConfig
paths
outFile :: String
outFile = String -> String
outputExecutable String
tempBinary
configFile' :: String
configFile' = PathsConfig -> String
configFile PathsConfig
paths
cacheDir' :: String
cacheDir' = PathsConfig -> String
cacheDirectory PathsConfig
paths
libsDir :: String
libsDir = PathsConfig -> String
libsDirectory PathsConfig
paths
String -> IO ()
output (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Configuration '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
configFile' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' changed. Recompiling."
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir'
String
errFile <- Params cfgType a -> IO String
forall cfgType a. Params cfgType a -> IO String
getErrorPath Params cfgType a
params
ExitCode
result <- String -> IOMode -> (Handle -> IO ExitCode) -> IO ExitCode
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
errFile IOMode
WriteMode ((Handle -> IO ExitCode) -> IO ExitCode)
-> (Handle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Handle
errHandle -> do
[String]
flags <- Params cfgType a
-> String -> String -> String -> String -> IO [String]
forall cfgType a.
Params cfgType a
-> String -> String -> String -> String -> IO [String]
makeFlags Params cfgType a
params String
configFile' String
outFile String
cacheDir' String
libsDir
Maybe String
stackYaml <- do
let stackYamlPath :: String
stackYamlPath = String -> String
takeDirectory String
configFile' String -> String -> String
</> String
"stack.yaml"
Bool
stackYamlExists <- String -> IO Bool
doesFileExist String
stackYamlPath
if Bool
stackYamlExists
then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
stackYamlPath
else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Maybe String
hc' <- String -> IO (Maybe String)
lookupEnv String
"HC"
Maybe String
nix_ghc <- String -> IO (Maybe String)
lookupEnv String
"NIX_GHC"
let hc :: String
hc = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"ghc" (Maybe String
hc' Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
nix_ghc)
ProcessHandle
ghcProc <- IO ProcessHandle
-> (String -> IO ProcessHandle) -> Maybe String -> IO ProcessHandle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
hc [String]
flags (String -> Maybe String
forall a. a -> Maybe a
Just String
cacheDir') Maybe [(String, String)]
forall a. Maybe a
Nothing
Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
errHandle))
(\String
stackYaml' -> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
"stack" (String
"ghc" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--stack-yaml" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
stackYaml' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
flags)
Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
errHandle))
Maybe String
stackYaml
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ghcProc
case ExitCode
result of
ExitCode
ExitSuccess -> do
String -> String -> IO ()
renameFile String
outFile String
tempBinary
String -> IO ()
removeFileIfExists String
errFile
String -> IO ()
output String
"Program reconfiguration successful."
ExitCode
_ -> do
String -> IO ()
removeFileIfExists String
tempBinary
String -> IO ()
output String
"Error occurred while loading configuration file."
makeFlags :: Params cfgType a -> FilePath -> FilePath -> FilePath
-> FilePath -> IO [String]
makeFlags :: forall cfgType a.
Params cfgType a
-> String -> String -> String -> String -> IO [String]
makeFlags Params cfgType a
params String
cfgFile String
outFile String
cacheDir' String
libsDir = do
String
currentDir <- IO String
getCurrentDirectory
[String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String])
-> ([[String]] -> [String]) -> [[String]] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> IO [String]) -> [[String]] -> IO [String]
forall a b. (a -> b) -> a -> b
$
[ [String
"-v0", String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
libsDir]
, [String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
currentDir | Params cfgType a -> Bool
forall cfgType a. Params cfgType a -> Bool
includeCurrentDirectory Params cfgType a
params]
, String -> [String] -> [String]
forall {t :: * -> *} {b}. Foldable t => b -> t b -> [b]
prefix String
"-hide-package" (Params cfgType a -> [String]
forall cfgType a. Params cfgType a -> [String]
hidePackages Params cfgType a
params)
, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Params cfgType a -> [String]
forall cfgType a. Params cfgType a -> [String]
includeDirs Params cfgType a
params)
, Params cfgType a -> [String]
forall cfgType a. Params cfgType a -> [String]
includeDirs Params cfgType a
params [String] -> (String -> [String]) -> [String]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> [String]
getCabalStoreGhcArgs (Params cfgType a -> String
forall cfgType a. Params cfgType a -> String
projectName Params cfgType a
params)
, Params cfgType a -> [String]
forall cfgType a. Params cfgType a -> [String]
ghcOpts Params cfgType a
params
, [ String
"-threaded" | Bool
rtsSupportsBoundThreads ]
, [String
"--make", String
cfgFile, String
"-outputdir", String
cacheDir', String
"-o", String
outFile]
, [String
"-fforce-recomp" | Params cfgType a -> Bool
forall cfgType a. Params cfgType a -> Bool
forceRecomp Params cfgType a
params]
]
where prefix :: b -> t b -> [b]
prefix b
y = (b -> [b]) -> t b -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((b -> [b]) -> t b -> [b]) -> (b -> [b]) -> t b -> [b]
forall a b. (a -> b) -> a -> b
$ \b
x -> [b
y,b
x]
getCabalStoreGhcArgs :: String -> FilePath -> [String]
getCabalStoreGhcArgs :: String -> String -> [String]
getCabalStoreGhcArgs String
proj = Maybe (String, [String]) -> [String]
mkArgs (Maybe (String, [String]) -> [String])
-> (String -> Maybe (String, [String])) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe (String, [String])
go ([String] -> Maybe (String, [String]))
-> (String -> [String]) -> String -> Maybe (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropTrailingPathSeparator ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath
where
go :: [String] -> Maybe (String , [String] )
go :: [String] -> Maybe (String, [String])
go (String
dir : String
"store" : String
hc : String
unit : [String]
_)
| String
dir String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".cabal", String
"cabal" ]
, String -> Maybe String
pkgNameFromUnitId String
unit Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
proj
= (String, [String]) -> Maybe (String, [String])
forall a. a -> Maybe a
Just (String
unit, [String
dir, String
"store", String
hc, String
"package.db"])
go (String
h : t :: [String]
t@(String
_cabal : String
_store : String
_hc : String
_unit : [String]
_))
= ([String] -> [String]) -> (String, [String]) -> (String, [String])
forall a b. (a -> b) -> (String, a) -> (String, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
hString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ((String, [String]) -> (String, [String]))
-> Maybe (String, [String]) -> Maybe (String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Maybe (String, [String])
go [String]
t
go [String]
_
= Maybe (String, [String])
forall a. Maybe a
Nothing
mkArgs :: Maybe (String, [String]) -> [String]
mkArgs Maybe (String, [String])
Nothing = []
mkArgs (Just (String
unitId, [String]
pkgDb)) = [String
"-package-db", [String] -> String
joinPath [String]
pkgDb, String
"-package-id", String
unitId]
pkgNameFromUnitId :: String -> Maybe String
pkgNameFromUnitId :: String -> Maybe String
pkgNameFromUnitId = ([String] -> String) -> Maybe [String] -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-") (Maybe [String] -> Maybe String)
-> (String -> Maybe [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe [String]
forall {a}. [a] -> Maybe [a]
go ([String] -> Maybe [String])
-> (String -> [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'-'
where
go :: [a] -> Maybe [a]
go [a
s,a
_,a
_] = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
s]
go (a
s:[a]
rest) = (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
go [a]
rest
go [] = Maybe [a]
forall a. Maybe a
Nothing
splitOn :: (Eq a) => a -> [a] -> [[a]]
splitOn :: forall a. Eq a => a -> [a] -> [[a]]
splitOn a
a [a]
l = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a) [a]
l of
([a]
h, []) -> [[a]
h]
([a]
h, a
_ : [a]
t) -> [a]
h [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
splitOn a
a [a]
t
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists :: String -> IO ()
removeFileIfExists String
path = do
Bool
exists <- String -> IO Bool
doesFileExist String
path
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
path