{- |
Compiling the custom executable. The majority of the code actually
deals with error handling, and not the compilation itself /per se/.
-}
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(..) )

-- | Return the path to the error file.
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

-- | If the error file exists and actually has some contents, return
--   'Just' the error string. Otherwise return 'Nothing'.
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

-- | Attempts to compile the configuration file. Will return a string
--   containing any compiler output.
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'

    -- Compile occurs in here
    [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

        -- GHC sometimes prints to stderr, even on success.
        -- Other parts of dyre infer error if error file exists
        -- and is non-empty, so remove it.
        [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."

-- | Assemble the arguments to GHC so everything compiles right.
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)

    -- add extra include dirs
    , ([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

    -- if the current process uses threaded RTS,
    -- also compile custom executable with -threaded
    , [ [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] -- Only if force is true
    ]
  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]

-- | Given a path to lib dir, if it is a package in the Cabal
-- store that matches the projectName, return GHC arguments
-- to enable the Cabal store package database and expose the
-- application's library package.
--
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 {- unit-id -}, [String] {- package-db -})
  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