content: {- |
  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 params =
    (</> "errors.log") . cacheDirectory <$> getPathsConfig 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 = do
      errorPath   <- getErrorPath 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 params@Params{statusOut = output} = do
      paths <- getPathsConfig params
      let
        tempBinary = customExecutable paths
        outFile = outputExecutable tempBinary
        configFile' = configFile paths
        cacheDir' = cacheDirectory paths
        libsDir = libsDirectory paths
  
      output $ "Configuration '" ++ configFile' ++  "' changed. Recompiling."
      createDirectoryIfMissing True cacheDir'
  
      -- Compile occurs in here
      errFile <- getErrorPath params
      result <- withFile errFile WriteMode $ \errHandle -> do
          flags <- makeFlags params configFile' outFile cacheDir' libsDir
          stackYaml <- do
            let stackYamlPath = takeDirectory configFile' </> "stack.yaml"
            stackYamlExists <- doesFileExist stackYamlPath
            if stackYamlExists
              then return $ Just stackYamlPath
              else return Nothing
  
          hc' <- lookupEnv "HC"
          nix_ghc <- lookupEnv "NIX_GHC"
          let hc = fromMaybe "ghc" (hc' <|> nix_ghc)
          ghcProc <- maybe (runProcess hc flags (Just cacheDir') Nothing
                                Nothing Nothing (Just errHandle))
                           (\stackYaml' -> runProcess "stack" ("ghc" : "--stack-yaml" : stackYaml' : "--" : flags)
                                Nothing Nothing Nothing Nothing (Just errHandle))
                           stackYaml
          waitForProcess ghcProc
  
      case result of
        ExitSuccess -> do
          renameFile outFile 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.
          removeFileIfExists errFile
  
          output "Program reconfiguration successful."
  
        _ -> do
          removeFileIfExists tempBinary
          output "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 cfgFile outFile cacheDir' libsDir = do
    currentDir <- 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 y = concatMap $ \x -> [y,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 proj = mkArgs . go . fmap dropTrailingPathSeparator . splitPath
    where
    go :: [String] -> Maybe (String {- unit-id -}, [String] {- package-db -})
    go (dir : "store" : hc : unit : _)
      | dir `elem` [".cabal", "cabal" {- probably under $XDG_STATE_HOME -}]
      , pkgNameFromUnitId unit == Just proj
      = Just (unit, [dir, "store", hc, "package.db"])
    go (h : t@(_cabal : _store : _hc : _unit : _))
      = fmap (h:) <$> go t
    go _
      = Nothing
  
    mkArgs Nothing = []
    mkArgs (Just (unitId, pkgDb)) = ["-package-db", joinPath pkgDb, "-package-id", 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 = fmap (intercalate "-") . go . splitOn '-'
    where
    go [s,_,_]  = Just [s]  -- drop the version and hash
    go (s:rest) = (s:) <$> go rest
    go []       = Nothing
  
  splitOn :: (Eq a) => a -> [a] -> [[a]]
  splitOn a l = case span (/= a) l of
    (h, []) -> [h]
    (h, _ : t) -> h : splitOn a t
  
  removeFileIfExists :: FilePath -> IO ()
  removeFileIfExists path = do
    exists <- doesFileExist path
    when exists $ removeFile path
  