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