{- |
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.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(..) )

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

-- | 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 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

-- | 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 -> 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'

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

        -- 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.
        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."

-- | 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
-> 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)

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

    -- if the current process uses threaded RTS,
    -- also compile custom executable with -threaded
    , [ 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] -- 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 :: 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 {- unit-id -}, [String] {- package-db -})
  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" {- probably under $XDG_STATE_HOME -}]
    , 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]

-- | Extract package name from a unit-id, or return @Nothing@
-- if the input does not look like a unit-id.
--
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]  -- drop the version and hash
  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