{- |
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
    errorPath   <- Params cfgType a -> IO String
forall cfgType a. Params cfgType a -> IO String
getErrorPath Params cfgType a
params
    errorsExist <- doesFileExist errorPath
    if not errorsExist
       then return Nothing
       else do errorData <- readFile errorPath
               if errorData == ""
                  then return Nothing
                  else return . Just $ 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
    paths <- Params cfgType a -> IO PathsConfig
forall cfg a. Params cfg a -> IO PathsConfig
getPathsConfig Params cfgType a
params
    let
      tempBinary = PathsConfig -> String
customExecutable PathsConfig
paths
      outFile = String -> String
outputExecutable String
tempBinary
      configFile' = PathsConfig -> String
configFile PathsConfig
paths
      cacheDir' = PathsConfig -> String
cacheDirectory PathsConfig
paths
      libsDir = PathsConfig -> String
libsDirectory PathsConfig
paths

    output $ "Configuration '" ++ configFile' ++  "' changed. Recompiling."
    createDirectoryIfMissing True cacheDir'

    -- Compile occurs in here
    errFile <- getErrorPath params
    result <- withFile errFile WriteMode $ \Handle
errHandle -> do
        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
        stackYaml <- do
          let stackYamlPath = String -> String
takeDirectory String
configFile' String -> String -> String
</> String
"stack.yaml"
          stackYamlExists <- doesFileExist stackYamlPath
          if stackYamlExists
            then return $ Just stackYamlPath
            else return Nothing

        hc' <- lookupEnv "HC"
        nix_ghc <- lookupEnv "NIX_GHC"
        let 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)
        ghcProc <- maybe (runProcess hc flags (Just cacheDir') Nothing
                              Nothing Nothing (Just 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))
                         stackYaml
        waitForProcess ghcProc

    case 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
  currentDir <- IO String
getCurrentDirectory
  pure . concat $
    [ ["-v0", "-i" ++ libsDir]
    , ["-i" ++ currentDir | includeCurrentDirectory params]
    , prefix "-hide-package" (hidePackages params)

    -- add extra include dirs
    , fmap ("-i" ++) (includeDirs params)

    , includeDirs params >>= getCabalStoreGhcArgs (projectName params)

    , ghcOpts params

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

    , ["--make", cfgFile, "-outputdir", cacheDir', "-o", outFile]
    , ["-fforce-recomp" | forceRecomp 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
  exists <- String -> IO Bool
doesFileExist String
path
  when exists $ removeFile path