{- |
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") forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathsConfig -> String
cacheDirectory forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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   <- 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       else do String
errorData <- String -> IO String
readFile String
errorPath
               if String
errorData forall a. Eq a => a -> a -> Bool
== String
""
                  then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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 <- 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 forall a b. (a -> b) -> a -> b
$ String
"Configuration '" forall a. [a] -> [a] -> [a]
++ String
configFile' forall a. [a] -> [a] -> [a]
++  String
"' changed. Recompiling."
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir'

    -- Compile occurs in here
    String
errFile <- forall cfgType a. Params cfgType a -> IO String
getErrorPath Params cfgType a
params
    ExitCode
result <- forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
errFile IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
errHandle -> do
        [String]
flags <- 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
stackYamlPath
            else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. a -> Maybe a -> a
fromMaybe String
"ghc" (Maybe String
hc' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
nix_ghc)
        ProcessHandle
ghcProc <- 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 (forall a. a -> Maybe a
Just String
cacheDir') forall a. Maybe a
Nothing
                              forall a. Maybe a
Nothing forall a. Maybe a
Nothing (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" forall a. a -> [a] -> [a]
: String
"--stack-yaml" forall a. a -> [a] -> [a]
: String
stackYaml' forall a. a -> [a] -> [a]
: String
"--" forall a. a -> [a] -> [a]
: [String]
flags)
                              forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    [ [String
"-v0", String
"-i" forall a. [a] -> [a] -> [a]
++ String
libsDir]
    , [String
"-i" forall a. [a] -> [a] -> [a]
++ String
currentDir | forall cfgType a. Params cfgType a -> Bool
includeCurrentDirectory Params cfgType a
params]
    , forall {t :: * -> *} {b}. Foldable t => b -> t b -> [b]
prefix String
"-hide-package" (forall cfgType a. Params cfgType a -> [String]
hidePackages Params cfgType a
params)

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

    , forall cfgType a. Params cfgType a -> [String]
includeDirs Params cfgType a
params forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> [String]
getCabalStoreGhcArgs (forall cfgType a. Params cfgType a -> String
projectName Params cfgType a
params)

    , 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" | 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe (String, [String])
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropTrailingPathSeparator 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 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
proj
    = 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]
_))
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
hforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Maybe (String, [String])
go [String]
t
  go [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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> [[a]] -> [a]
intercalate String
"-") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> Maybe [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'-'
  where
  go :: [a] -> Maybe [a]
go [a
s,a
_,a
_]  = forall a. a -> Maybe a
Just [a
s]  -- drop the version and hash
  go (a
s:[a]
rest) = (a
sforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
go [a]
rest
  go []       = 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= a
a) [a]
l of
  ([a]
h, []) -> [[a]
h]
  ([a]
h, a
_ : [a]
t) -> [a]
h forall 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
path