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