{- |
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 Data.Monoid (Alt(..))
import System.IO         ( IOMode(WriteMode), withFile )
import System.Environment (lookupEnv)
import System.Exit       ( ExitCode(..) )
import System.Process    ( runProcess, waitForProcess )
import System.FilePath
  ( (</>), dropTrailingPathSeparator, 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 :: Params cfgType a -> IO FilePath
getErrorPath Params cfgType a
params =
  (FilePath -> FilePath -> FilePath
</> FilePath
"errors.log") (FilePath -> FilePath)
-> (PathsConfig -> FilePath) -> PathsConfig -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsConfig -> FilePath
cacheDirectory (PathsConfig -> FilePath) -> IO PathsConfig -> IO FilePath
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 :: Params cfgType a -> IO (Maybe FilePath)
getErrorString Params cfgType a
params = do
    FilePath
errorPath   <- Params cfgType a -> IO FilePath
forall cfgType a. Params cfgType a -> IO FilePath
getErrorPath Params cfgType a
params
    Bool
errorsExist <- FilePath -> IO Bool
doesFileExist FilePath
errorPath
    if Bool -> Bool
not Bool
errorsExist
       then Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
       else do FilePath
errorData <- FilePath -> IO FilePath
readFile FilePath
errorPath
               if FilePath
errorData FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
""
                  then Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
                  else Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> (FilePath -> Maybe FilePath) -> FilePath -> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> IO (Maybe FilePath))
-> FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
errorData

-- | Attempts to compile the configuration file. Will return a string
--   containing any compiler output.
customCompile :: Params cfgType a -> IO ()
customCompile :: Params cfgType a -> IO ()
customCompile params :: Params cfgType a
params@Params{statusOut :: forall cfgType a. Params cfgType a -> FilePath -> IO ()
statusOut = FilePath -> 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 :: FilePath
tempBinary = PathsConfig -> FilePath
customExecutable PathsConfig
paths
      outFile :: FilePath
outFile = FilePath -> FilePath
outputExecutable FilePath
tempBinary
      configFile' :: FilePath
configFile' = PathsConfig -> FilePath
configFile PathsConfig
paths
      cacheDir' :: FilePath
cacheDir' = PathsConfig -> FilePath
cacheDirectory PathsConfig
paths
      libsDir :: FilePath
libsDir = PathsConfig -> FilePath
libsDirectory PathsConfig
paths

    FilePath -> IO ()
output (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Configuration '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
configFile' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++  FilePath
"' changed. Recompiling."
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
cacheDir'

    -- Compile occurs in here
    FilePath
errFile <- Params cfgType a -> IO FilePath
forall cfgType a. Params cfgType a -> IO FilePath
getErrorPath Params cfgType a
params
    ExitCode
result <- FilePath -> IOMode -> (Handle -> IO ExitCode) -> IO ExitCode
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
errFile IOMode
WriteMode ((Handle -> IO ExitCode) -> IO ExitCode)
-> (Handle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Handle
errHandle -> do
        [FilePath]
flags <- Params cfgType a
-> FilePath -> FilePath -> FilePath -> FilePath -> IO [FilePath]
forall cfgType a.
Params cfgType a
-> FilePath -> FilePath -> FilePath -> FilePath -> IO [FilePath]
makeFlags Params cfgType a
params FilePath
configFile' FilePath
outFile FilePath
cacheDir' FilePath
libsDir
        Maybe FilePath
stackYaml <- do
          let stackYamlPath :: FilePath
stackYamlPath = FilePath -> FilePath
takeDirectory FilePath
configFile' FilePath -> FilePath -> FilePath
</> FilePath
"stack.yaml"
          Bool
stackYamlExists <- FilePath -> IO Bool
doesFileExist FilePath
stackYamlPath
          if Bool
stackYamlExists
            then Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
stackYamlPath
            else Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

        FilePath
hc <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"ghc" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"HC"
        ProcessHandle
ghcProc <- IO ProcessHandle
-> (FilePath -> IO ProcessHandle)
-> Maybe FilePath
-> IO ProcessHandle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess FilePath
hc [FilePath]
flags (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
cacheDir') Maybe [(FilePath, FilePath)]
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))
                         (\FilePath
stackYaml' -> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess FilePath
"stack" (FilePath
"ghc" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath
"--stack-yaml" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath
stackYaml' FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath
"--" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
flags)
                              Maybe FilePath
forall a. Maybe a
Nothing Maybe [(FilePath, FilePath)]
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 FilePath
stackYaml
        ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ghcProc

    case ExitCode
result of
      ExitCode
ExitSuccess -> do
        FilePath -> FilePath -> IO ()
renameFile FilePath
outFile FilePath
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.
        FilePath -> IO ()
removeFileIfExists FilePath
errFile

        FilePath -> IO ()
output FilePath
"Program reconfiguration successful."

      ExitCode
_ -> do
        FilePath -> IO ()
removeFileIfExists FilePath
tempBinary
        FilePath -> IO ()
output FilePath
"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 :: Params cfgType a
-> FilePath -> FilePath -> FilePath -> FilePath -> IO [FilePath]
makeFlags Params cfgType a
params FilePath
cfgFile FilePath
outFile FilePath
cacheDir' FilePath
libsDir = do
  FilePath
currentDir <- IO FilePath
getCurrentDirectory
  [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> IO [FilePath]) -> [[FilePath]] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
    [ [FilePath
"-v0", FilePath
"-i" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
libsDir]
    , [FilePath
"-i" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
currentDir | Params cfgType a -> Bool
forall cfgType a. Params cfgType a -> Bool
includeCurrentDirectory Params cfgType a
params]
    , FilePath -> [FilePath] -> [FilePath]
forall (t :: * -> *) b. Foldable t => b -> t b -> [b]
prefix FilePath
"-hide-package" (Params cfgType a -> [FilePath]
forall cfgType a. Params cfgType a -> [FilePath]
hidePackages Params cfgType a
params)

    -- add extra include dirs
    , (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
"-i" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (Params cfgType a -> [FilePath]
forall cfgType a. Params cfgType a -> [FilePath]
includeDirs Params cfgType a
params)

    -- add -package-id <unit> if extra include dir is a cabal
    -- store package matching the Dyre projectName
    , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((:) FilePath
"-package-id" ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Maybe FilePath -> [FilePath])
-> (Alt Maybe FilePath -> Maybe FilePath)
-> Alt Maybe FilePath
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt Maybe FilePath -> Maybe FilePath
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt
      (Alt Maybe FilePath -> [FilePath])
-> Alt Maybe FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Alt Maybe FilePath)
-> [FilePath] -> Alt Maybe FilePath
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe FilePath -> Alt Maybe FilePath
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (Maybe FilePath -> Alt Maybe FilePath)
-> (FilePath -> Maybe FilePath) -> FilePath -> Alt Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Maybe FilePath
getUnitId (Params cfgType a -> FilePath
forall cfgType a. Params cfgType a -> FilePath
projectName Params cfgType a
params)) (Params cfgType a -> [FilePath]
forall cfgType a. Params cfgType a -> [FilePath]
includeDirs Params cfgType a
params)

    , Params cfgType a -> [FilePath]
forall cfgType a. Params cfgType a -> [FilePath]
ghcOpts Params cfgType a
params

    -- if the current process uses threaded RTS,
    -- also compile custom executable with -threaded
    , [ FilePath
"-threaded" | Bool
rtsSupportsBoundThreads ]

    , [FilePath
"--make", FilePath
cfgFile, FilePath
"-outputdir", FilePath
cacheDir', FilePath
"-o", FilePath
outFile]
    , [FilePath
"-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, extract the unit-id.
--
getUnitId :: String -> FilePath -> Maybe String
getUnitId :: FilePath -> FilePath -> Maybe FilePath
getUnitId FilePath
proj = [FilePath] -> Maybe FilePath
go ([FilePath] -> Maybe FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropTrailingPathSeparator ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitPath
  where
  go :: [FilePath] -> Maybe FilePath
go (FilePath
".cabal" : FilePath
"store" : FilePath
_hc : FilePath
unit : [FilePath]
_) =
    case Char -> FilePath -> [FilePath]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'-' FilePath
unit of
      [FilePath
s, FilePath
_, FilePath
_] | FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
proj -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
unit
      [FilePath]
_                     -> Maybe FilePath
forall a. Maybe a
Nothing
  go (FilePath
_ : t :: [FilePath]
t@(FilePath
_cabal : FilePath
_store : FilePath
_hc : FilePath
_unit : [FilePath]
_)) = [FilePath] -> Maybe FilePath
go [FilePath]
t
  go [FilePath]
_ = Maybe FilePath
forall a. Maybe a
Nothing

splitOn :: (Eq a) => a -> [a] -> [[a]]
splitOn :: 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 :: FilePath -> IO ()
removeFileIfExists FilePath
path = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
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
$ FilePath -> IO ()
removeFile FilePath
path