{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module HIE.Bios.Cradle (
      findCradle
    , loadCradle
    , loadImplicitCradle
    , yamlConfig
    , defaultCradle
    , isCabalCradle
    , isStackCradle
    , isDirectCradle
    , isBiosCradle
    , isNoneCradle
    , isMultiCradle
    , isDefaultCradle
    , isOtherCradle
    , getCradle
    , readProcessWithOutputs
    , readProcessWithCwd
    , makeCradleResult
  ) where

import Control.Applicative ((<|>), optional)
import Data.Bifunctor (first)
import Control.DeepSeq
import Control.Exception (handleJust)
import qualified Data.Yaml as Yaml
import Data.Void
import Data.Char (isSpace)
import System.Exit
import System.Directory hiding (findFile)
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import Control.Monad
import Control.Monad.Extra (unlessM)
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Conduit.Process
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit as C
import qualified Data.Conduit.Text as C
import qualified Data.HashMap.Strict as Map
import Data.Maybe (fromMaybe, maybeToList)
import Data.List
import Data.List.Extra (trimEnd)
import Data.Ord (Down(..))
import qualified Data.Text as T
import System.Environment
import System.FilePath
import System.PosixCompat.Files
import System.Info.Extra (isWindows)
import System.IO (hClose, hGetContents, hSetBuffering, BufferMode(LineBuffering), withFile, IOMode(..))
import System.IO.Error (isPermissionError)
import System.IO.Temp

import HIE.Bios.Config
import HIE.Bios.Environment (getCacheDir)
import HIE.Bios.Types hiding (ActionName(..))
import HIE.Bios.Wrappers
import qualified HIE.Bios.Types as Types
import qualified HIE.Bios.Ghc.Gap as Gap

import GHC.Fingerprint (fingerprintString)
import GHC.ResponseFile (escapeArgs)

----------------------------------------------------------------
-- Environment variables used by hie-bios.
--
-- If you need more, add a constant here.
----------------------------------------------------------------

-- | Environment variable containing the filepath to which
-- cradle actions write their results to.
-- If the filepath does not exist, cradle actions must create them.
hie_bios_output :: String
hie_bios_output :: String
hie_bios_output = String
"HIE_BIOS_OUTPUT"

-- | Environment variable pointing to the GHC location used by
-- cabal's and stack's GHC wrapper.
--
-- If not set, will default to sensible defaults.
hie_bios_ghc :: String
hie_bios_ghc :: String
hie_bios_ghc = String
"HIE_BIOS_GHC"

-- | Environment variable with extra arguments passed to the GHC location
-- in cabal's and stack's GHC wrapper.
--
-- If not set, assume no extra arguments.
hie_bios_ghc_args :: String
hie_bios_ghc_args :: String
hie_bios_ghc_args = String
"HIE_BIOS_GHC_ARGS"

-- | Environment variable pointing to the source file location that caused
-- the cradle action to be executed.
hie_bios_arg :: String
hie_bios_arg :: String
hie_bios_arg = String
"HIE_BIOS_ARG"

-- | Environment variable pointing to a filepath to which dependencies
-- of a cradle can be written to by the cradle action.
hie_bios_deps :: String
hie_bios_deps :: String
hie_bios_deps = String
"HIE_BIOS_DEPS"

----------------------------------------------------------------

-- | Given root\/foo\/bar.hs, return root\/hie.yaml, or wherever the yaml file was found.
findCradle :: FilePath -> IO (Maybe FilePath)
findCradle :: String -> IO (Maybe String)
findCradle String
wfile = do
    let wdir :: String
wdir = String -> String
takeDirectory String
wfile
    MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (String -> MaybeT IO String
yamlConfig String
wdir)

-- | Given root\/hie.yaml load the Cradle.
loadCradle :: FilePath -> IO (Cradle Void)
loadCradle :: String -> IO (Cradle Void)
loadCradle = (Void -> Cradle Void) -> String -> IO (Cradle Void)
forall b a.
FromJSON b =>
(b -> Cradle a) -> String -> IO (Cradle a)
loadCradleWithOpts Void -> Cradle Void
forall a. Void -> a
absurd

-- | Given root\/foo\/bar.hs, load an implicit cradle
loadImplicitCradle :: Show a => FilePath -> IO (Cradle a)
loadImplicitCradle :: String -> IO (Cradle a)
loadImplicitCradle String
wfile = do
  let wdir :: String
wdir = String -> String
takeDirectory String
wfile
  Maybe (CradleConfig Void, String)
cfg <- MaybeT IO (CradleConfig Void, String)
-> IO (Maybe (CradleConfig Void, String))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (String -> MaybeT IO (CradleConfig Void, String)
forall a. String -> MaybeT IO (CradleConfig a, String)
implicitConfig String
wdir)
  Cradle a -> IO (Cradle a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cradle a -> IO (Cradle a)) -> Cradle a -> IO (Cradle a)
forall a b. (a -> b) -> a -> b
$ case Maybe (CradleConfig Void, String)
cfg of
    Just (CradleConfig Void, String)
bc -> (Void -> Cradle a) -> (CradleConfig Void, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle Void -> Cradle a
forall a. Void -> a
absurd (CradleConfig Void, String)
bc
    Maybe (CradleConfig Void, String)
Nothing -> String -> Cradle a
forall a. String -> Cradle a
defaultCradle String
wdir

-- | Finding 'Cradle'.
--   Find a cabal file by tracing ancestor directories.
--   Find a sandbox according to a cabal sandbox config
--   in a cabal directory.
loadCradleWithOpts :: (Yaml.FromJSON b) => (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCradleWithOpts :: (b -> Cradle a) -> String -> IO (Cradle a)
loadCradleWithOpts b -> Cradle a
buildCustomCradle String
wfile = do
    CradleConfig b
cradleConfig <- String -> IO (CradleConfig b)
forall b. FromJSON b => String -> IO (CradleConfig b)
readCradleConfig String
wfile
    Cradle a -> IO (Cradle a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cradle a -> IO (Cradle a)) -> Cradle a -> IO (Cradle a)
forall a b. (a -> b) -> a -> b
$ (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
cradleConfig, String -> String
takeDirectory String
wfile)

getCradle :: (b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
getCradle :: (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
cc, String
wdir) = [String] -> Cradle a -> Cradle a
forall a. [String] -> Cradle a -> Cradle a
addCradleDeps [String]
cradleDeps (Cradle a -> Cradle a) -> Cradle a -> Cradle a
forall a b. (a -> b) -> a -> b
$ case CradleConfig b -> CradleType b
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig b
cc of
    Cabal CabalType{ cabalComponent :: CabalType -> Maybe String
cabalComponent = Maybe String
mc } -> String -> Maybe String -> Cradle a
forall a. String -> Maybe String -> Cradle a
cabalCradle String
wdir Maybe String
mc
    CabalMulti CabalType
dc [(String, CabalType)]
ms ->
      (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle
        ([String] -> CradleType b -> CradleConfig b
forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig [String]
cradleDeps
          ([(String, CradleConfig b)] -> CradleType b
forall a. [(String, CradleConfig a)] -> CradleType a
Multi [(String
p, [String] -> CradleType b -> CradleConfig b
forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig [] (CabalType -> CradleType b
forall a. CabalType -> CradleType a
Cabal (CabalType -> CradleType b) -> CabalType -> CradleType b
forall a b. (a -> b) -> a -> b
$ CabalType
dc CabalType -> CabalType -> CabalType
forall a. Semigroup a => a -> a -> a
<> CabalType
c)) | (String
p, CabalType
c) <- [(String, CabalType)]
ms])
        , String
wdir)
    Stack StackType{ stackComponent :: StackType -> Maybe String
stackComponent = Maybe String
mc, stackYaml :: StackType -> Maybe String
stackYaml = Maybe String
syaml} ->
      let
        stackYamlConfig :: StackYaml
stackYamlConfig = String -> Maybe String -> StackYaml
stackYamlFromMaybe String
wdir Maybe String
syaml
      in
        String -> Maybe String -> StackYaml -> Cradle a
forall a. String -> Maybe String -> StackYaml -> Cradle a
stackCradle String
wdir Maybe String
mc StackYaml
stackYamlConfig
    StackMulti StackType
ds [(String, StackType)]
ms ->
      (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle
        ([String] -> CradleType b -> CradleConfig b
forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig [String]
cradleDeps
          ([(String, CradleConfig b)] -> CradleType b
forall a. [(String, CradleConfig a)] -> CradleType a
Multi [(String
p, [String] -> CradleType b -> CradleConfig b
forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig [] (StackType -> CradleType b
forall a. StackType -> CradleType a
Stack (StackType -> CradleType b) -> StackType -> CradleType b
forall a b. (a -> b) -> a -> b
$ StackType
ds StackType -> StackType -> StackType
forall a. Semigroup a => a -> a -> a
<> StackType
c)) | (String
p, StackType
c) <- [(String, StackType)]
ms])
        , String
wdir)
 --   Bazel -> rulesHaskellCradle wdir
 --   Obelisk -> obeliskCradle wdir
    Bios Callable
bios Maybe Callable
deps Maybe String
mbGhc -> String -> Callable -> Maybe Callable -> Maybe String -> Cradle a
forall a.
String -> Callable -> Maybe Callable -> Maybe String -> Cradle a
biosCradle String
wdir Callable
bios Maybe Callable
deps Maybe String
mbGhc
    Direct [String]
xs -> String -> [String] -> Cradle a
forall a. String -> [String] -> Cradle a
directCradle String
wdir [String]
xs
    CradleType b
None      -> String -> Cradle a
forall a. String -> Cradle a
noneCradle String
wdir
    Multi [(String, CradleConfig b)]
ms  -> (b -> Cradle a) -> String -> [(String, CradleConfig b)] -> Cradle a
forall b a.
(b -> Cradle a) -> String -> [(String, CradleConfig b)] -> Cradle a
multiCradle b -> Cradle a
buildCustomCradle String
wdir [(String, CradleConfig b)]
ms
    Other b
a Value
_ -> b -> Cradle a
buildCustomCradle b
a
    where
      cradleDeps :: [String]
cradleDeps = CradleConfig b -> [String]
forall a. CradleConfig a -> [String]
cradleDependencies CradleConfig b
cc

addCradleDeps :: [FilePath] -> Cradle a -> Cradle a
addCradleDeps :: [String] -> Cradle a -> Cradle a
addCradleDeps [String]
deps Cradle a
c =
  Cradle a
c { cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction a -> CradleAction a
forall a. CradleAction a -> CradleAction a
addActionDeps (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
c) }
  where
    addActionDeps :: CradleAction a -> CradleAction a
    addActionDeps :: CradleAction a -> CradleAction a
addActionDeps CradleAction a
ca =
      CradleAction a
ca { runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LogAction IO (WithSeverity Log)
l String
fp ->
            (CradleLoadResult ComponentOptions
-> (CradleError -> CradleLoadResult ComponentOptions)
-> (ComponentOptions -> CradleLoadResult ComponentOptions)
-> CradleLoadResult ComponentOptions
-> CradleLoadResult ComponentOptions
forall c r.
c -> (CradleError -> c) -> (r -> c) -> CradleLoadResult r -> c
cradleLoadResult
                CradleLoadResult ComponentOptions
forall r. CradleLoadResult r
CradleNone
                (\CradleError
err -> CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError
err { cradleErrorDependencies :: [String]
cradleErrorDependencies = CradleError -> [String]
cradleErrorDependencies CradleError
err [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` [String]
deps }))
                (\(ComponentOptions [String]
os' String
dir [String]
ds) -> ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ([String] -> String -> [String] -> ComponentOptions
ComponentOptions [String]
os' String
dir ([String]
ds [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` [String]
deps)))
            )
            (CradleLoadResult ComponentOptions
 -> CradleLoadResult ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CradleAction a
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
runCradle CradleAction a
ca LogAction IO (WithSeverity Log)
l String
fp
         }

-- | Try to infer an appropriate implicit cradle type from stuff we can find in the enclosing directories:
--   * If a .hie-bios file is found, we can treat this as a @Bios@ cradle
--   * If a stack.yaml file is found, we can treat this as a @Stack@ cradle
--   * If a cabal.project or an xyz.cabal file is found, we can treat this as a @Cabal@ cradle
inferCradleType :: FilePath -> MaybeT IO (CradleType a, FilePath)
inferCradleType :: String -> MaybeT IO (CradleType a, String)
inferCradleType String
fp =
       MaybeT IO (CradleType a, String)
forall a. MaybeT IO (CradleType a, String)
maybeItsBios
   MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleType a, String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO (CradleType a, String)
forall a. MaybeT IO (CradleType a, String)
maybeItsStack
   MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleType a, String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO (CradleType a, String)
forall a. MaybeT IO (CradleType a, String)
maybeItsCabal
-- <|> maybeItsObelisk
-- <|> maybeItsObelisk

  where
  maybeItsBios :: MaybeT IO (CradleType a, String)
maybeItsBios = (\String
wdir -> (Callable -> Maybe Callable -> Maybe String -> CradleType a
forall a.
Callable -> Maybe Callable -> Maybe String -> CradleType a
Bios (String -> Callable
Program (String -> Callable) -> String -> Callable
forall a b. (a -> b) -> a -> b
$ String
wdir String -> String -> String
</> String
".hie-bios") Maybe Callable
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing, String
wdir)) (String -> (CradleType a, String))
-> MaybeT IO String -> MaybeT IO (CradleType a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
biosWorkDir String
fp

  maybeItsStack :: MaybeT IO (CradleType a, String)
maybeItsStack = MaybeT IO String
stackExecutable MaybeT IO String
-> MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleType a, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (StackType -> CradleType a
forall a. StackType -> CradleType a
Stack (StackType -> CradleType a) -> StackType -> CradleType a
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing,) (String -> (CradleType a, String))
-> MaybeT IO String -> MaybeT IO (CradleType a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
stackWorkDir String
fp

  maybeItsCabal :: MaybeT IO (CradleType a, String)
maybeItsCabal = (CabalType -> CradleType a
forall a. CabalType -> CradleType a
Cabal (CabalType -> CradleType a) -> CabalType -> CradleType a
forall a b. (a -> b) -> a -> b
$ Maybe String -> CabalType
CabalType Maybe String
forall a. Maybe a
Nothing,) (String -> (CradleType a, String))
-> MaybeT IO String -> MaybeT IO (CradleType a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
cabalWorkDir String
fp

  -- maybeItsObelisk = (Obelisk,) <$> obeliskWorkDir fp

  -- maybeItsBazel = (Bazel,) <$> rulesHaskellWorkDir fp


-- | Wraps up the cradle inferred by @inferCradleType@ as a @CradleConfig@ with no dependencies
implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig :: String -> MaybeT IO (CradleConfig a, String)
implicitConfig = (((CradleType a, String) -> (CradleConfig a, String))
-> MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleConfig a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CradleType a, String) -> (CradleConfig a, String))
 -> MaybeT IO (CradleType a, String)
 -> MaybeT IO (CradleConfig a, String))
-> ((CradleType a -> CradleConfig a)
    -> (CradleType a, String) -> (CradleConfig a, String))
-> (CradleType a -> CradleConfig a)
-> MaybeT IO (CradleType a, String)
-> MaybeT IO (CradleConfig a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CradleType a -> CradleConfig a)
-> (CradleType a, String) -> (CradleConfig a, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) ([String] -> CradleType a -> CradleConfig a
forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig [String]
noDeps) (MaybeT IO (CradleType a, String)
 -> MaybeT IO (CradleConfig a, String))
-> (String -> MaybeT IO (CradleType a, String))
-> String
-> MaybeT IO (CradleConfig a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MaybeT IO (CradleType a, String)
forall a. String -> MaybeT IO (CradleType a, String)
inferCradleType
  where
  noDeps :: [FilePath]
  noDeps :: [String]
noDeps = []

yamlConfig :: FilePath ->  MaybeT IO FilePath
yamlConfig :: String -> MaybeT IO String
yamlConfig String
fp = do
  String
configDir <- String -> MaybeT IO String
yamlConfigDirectory String
fp
  String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
configDir String -> String -> String
</> String
configFileName)

yamlConfigDirectory :: FilePath -> MaybeT IO FilePath
yamlConfigDirectory :: String -> MaybeT IO String
yamlConfigDirectory = (String -> Bool) -> String -> MaybeT IO String
findFileUpwards (String
configFileName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==)

readCradleConfig :: Yaml.FromJSON b => FilePath -> IO (CradleConfig b)
readCradleConfig :: String -> IO (CradleConfig b)
readCradleConfig String
yamlHie = do
  Config b
cfg  <- IO (Config b) -> IO (Config b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Config b) -> IO (Config b)) -> IO (Config b) -> IO (Config b)
forall a b. (a -> b) -> a -> b
$ String -> IO (Config b)
forall a. FromJSON a => String -> IO (Config a)
readConfig String
yamlHie
  CradleConfig b -> IO (CradleConfig b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Config b -> CradleConfig b
forall a. Config a -> CradleConfig a
cradle Config b
cfg)

configFileName :: FilePath
configFileName :: String
configFileName = String
"hie.yaml"

-- | Pass '-dynamic' flag when GHC is built with dynamic linking.
--
-- Append flag to options of 'defaultCradle' and 'directCradle' if GHC is dynmically linked,
-- because unlike the case of using build tools, which means '-dynamic' can be set via
-- '.cabal' or 'package.yaml', users have to create an explicit hie.yaml to pass this flag.
argDynamic :: [String]
argDynamic :: [String]
argDynamic = [String
"-dynamic" | Bool
Gap.hostIsDynamic ]

---------------------------------------------------------------

isCabalCradle :: Cradle a -> Bool
isCabalCradle :: Cradle a -> Bool
isCabalCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Cabal -> Bool
True
  ActionName a
_ -> Bool
False

isStackCradle :: Cradle a -> Bool
isStackCradle :: Cradle a -> Bool
isStackCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Stack -> Bool
True
  ActionName a
_ -> Bool
False

isDirectCradle :: Cradle a -> Bool
isDirectCradle :: Cradle a -> Bool
isDirectCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Direct -> Bool
True
  ActionName a
_ -> Bool
False

isBiosCradle :: Cradle a -> Bool
isBiosCradle :: Cradle a -> Bool
isBiosCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Bios -> Bool
True
  ActionName a
_ -> Bool
False

isMultiCradle :: Cradle a -> Bool
isMultiCradle :: Cradle a -> Bool
isMultiCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Multi -> Bool
True
  ActionName a
_ -> Bool
False

isNoneCradle :: Cradle a -> Bool
isNoneCradle :: Cradle a -> Bool
isNoneCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.None -> Bool
True
  ActionName a
_ -> Bool
False

isDefaultCradle :: Cradle a -> Bool
isDefaultCradle :: Cradle a -> Bool
isDefaultCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  ActionName a
Types.Default -> Bool
True
  ActionName a
_ -> Bool
False

isOtherCradle :: Cradle a -> Bool
isOtherCradle :: Cradle a -> Bool
isOtherCradle Cradle a
crdl = case CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
crdl) of
  Types.Other a
_ -> Bool
True
  ActionName a
_ -> Bool
False

---------------------------------------------------------------

-- | Default cradle has no special options, not very useful for loading
-- modules.
defaultCradle :: FilePath -> Cradle a
defaultCradle :: String -> Cradle a
defaultCradle String
cur_dir =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir = String
cur_dir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Default
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LogAction IO (WithSeverity Log)
_ String
_ ->
            CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ([String] -> String -> [String] -> ComponentOptions
ComponentOptions [String]
argDynamic String
cur_dir []))
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath String
cur_dir
        }
    }

---------------------------------------------------------------
-- | The none cradle tells us not to even attempt to load a certain directory

noneCradle :: FilePath -> Cradle a
noneCradle :: String -> Cradle a
noneCradle String
cur_dir =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir = String
cur_dir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.None
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LogAction IO (WithSeverity Log)
_ String
_ -> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult ComponentOptions
forall r. CradleLoadResult r
CradleNone
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
_   -> CradleLoadResult String -> IO (CradleLoadResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult String
forall r. CradleLoadResult r
CradleNone
        }
    }

---------------------------------------------------------------
-- | The multi cradle selects a cradle based on the filepath

multiCradle :: (b -> Cradle a) -> FilePath -> [(FilePath, CradleConfig b)] -> Cradle a
multiCradle :: (b -> Cradle a) -> String -> [(String, CradleConfig b)] -> Cradle a
multiCradle b -> Cradle a
buildCustomCradle String
cur_dir [(String, CradleConfig b)]
cs =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir  = String
cur_dir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
multiActionName
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle  = \LogAction IO (WithSeverity Log)
l String
fp -> String -> IO String
makeAbsolute String
fp IO String
-> (String -> IO (CradleLoadResult ComponentOptions))
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> Cradle a)
-> String
-> [(String, CradleConfig b)]
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
forall b a.
(b -> Cradle a)
-> String
-> [(String, CradleConfig b)]
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
multiAction b -> Cradle a
buildCustomCradle String
cur_dir [(String, CradleConfig b)]
cs LogAction IO (WithSeverity Log)
l
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args ->
            -- We're being lazy here and just returning the ghc path for the
            -- first non-none cradle. This shouldn't matter in practice: all
            -- sub cradles should be using the same ghc version!
            case (CradleConfig b -> Bool) -> [CradleConfig b] -> [CradleConfig b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (CradleConfig b -> Bool) -> CradleConfig b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CradleConfig b -> Bool
forall a. CradleConfig a -> Bool
isNoneCradleConfig) ([CradleConfig b] -> [CradleConfig b])
-> [CradleConfig b] -> [CradleConfig b]
forall a b. (a -> b) -> a -> b
$ ((String, CradleConfig b) -> CradleConfig b)
-> [(String, CradleConfig b)] -> [CradleConfig b]
forall a b. (a -> b) -> [a] -> [b]
map (String, CradleConfig b) -> CradleConfig b
forall a b. (a, b) -> b
snd [(String, CradleConfig b)]
cs of
              [] -> CradleLoadResult String -> IO (CradleLoadResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult String
forall r. CradleLoadResult r
CradleNone
              (CradleConfig b
cfg:[CradleConfig b]
_) -> (CradleAction a -> [String] -> IO (CradleLoadResult String))
-> [String] -> CradleAction a -> IO (CradleLoadResult String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CradleAction a -> [String] -> IO (CradleLoadResult String)
forall a.
CradleAction a -> [String] -> IO (CradleLoadResult String)
runGhcCmd [String]
args (CradleAction a -> IO (CradleLoadResult String))
-> CradleAction a -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg (Cradle a -> CradleAction a) -> Cradle a -> CradleAction a
forall a b. (a -> b) -> a -> b
$
                (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
cfg, String
cur_dir)
        }
    }
  where
    cfgs :: [CradleConfig b]
cfgs = ((String, CradleConfig b) -> CradleConfig b)
-> [(String, CradleConfig b)] -> [CradleConfig b]
forall a b. (a -> b) -> [a] -> [b]
map (String, CradleConfig b) -> CradleConfig b
forall a b. (a, b) -> b
snd [(String, CradleConfig b)]
cs

    multiActionName :: ActionName a
multiActionName
      | (CradleConfig b -> Bool) -> [CradleConfig b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\CradleConfig b
c -> CradleConfig b -> Bool
forall a. CradleConfig a -> Bool
isStackCradleConfig CradleConfig b
c Bool -> Bool -> Bool
|| CradleConfig b -> Bool
forall a. CradleConfig a -> Bool
isNoneCradleConfig CradleConfig b
c) [CradleConfig b]
cfgs
      = ActionName a
forall a. ActionName a
Types.Stack
      | (CradleConfig b -> Bool) -> [CradleConfig b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\CradleConfig b
c -> CradleConfig b -> Bool
forall a. CradleConfig a -> Bool
isCabalCradleConfig CradleConfig b
c Bool -> Bool -> Bool
|| CradleConfig b -> Bool
forall a. CradleConfig a -> Bool
isNoneCradleConfig CradleConfig b
c) [CradleConfig b]
cfgs
      = ActionName a
forall a. ActionName a
Types.Cabal
      | Bool
otherwise
      = ActionName a
forall a. ActionName a
Types.Multi

    isStackCradleConfig :: CradleConfig a -> Bool
isStackCradleConfig CradleConfig a
cfg = case CradleConfig a -> CradleType a
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig a
cfg of
      Stack{}      -> Bool
True
      StackMulti{} -> Bool
True
      CradleType a
_            -> Bool
False

    isCabalCradleConfig :: CradleConfig a -> Bool
isCabalCradleConfig CradleConfig a
cfg = case CradleConfig a -> CradleType a
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig a
cfg of
      Cabal{}      -> Bool
True
      CabalMulti{} -> Bool
True
      CradleType a
_            -> Bool
False

    isNoneCradleConfig :: CradleConfig a -> Bool
isNoneCradleConfig CradleConfig a
cfg = case CradleConfig a -> CradleType a
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig a
cfg of
      CradleType a
None -> Bool
True
      CradleType a
_    -> Bool
False

multiAction
  ::  forall b a
  . (b -> Cradle a)
  -> FilePath
  -> [(FilePath, CradleConfig b)]
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> IO (CradleLoadResult ComponentOptions)
multiAction :: (b -> Cradle a)
-> String
-> [(String, CradleConfig b)]
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
multiAction b -> Cradle a
buildCustomCradle String
cur_dir [(String, CradleConfig b)]
cs LogAction IO (WithSeverity Log)
l String
cur_fp =
    [(String, CradleConfig b)]
-> IO (CradleLoadResult ComponentOptions)
selectCradle ([(String, CradleConfig b)]
 -> IO (CradleLoadResult ComponentOptions))
-> IO [(String, CradleConfig b)]
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [(String, CradleConfig b)]
canonicalizeCradles

  where
    err_msg :: [String]
err_msg = [String
"Multi Cradle: No prefixes matched"
              , String
"pwd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cur_dir
              , String
"filepath: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cur_fp
              , String
"prefixes:"
              ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(String, CradleType b) -> String
forall a. Show a => a -> String
show (String
pf, CradleConfig b -> CradleType b
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig b
cc) | (String
pf, CradleConfig b
cc) <- [(String, CradleConfig b)]
cs]

    -- Canonicalize the relative paths present in the multi-cradle and
    -- also order the paths by most specific first. In the cradle selection
    -- function we want to choose the most specific cradle possible.
    canonicalizeCradles :: IO [(FilePath, CradleConfig b)]
    canonicalizeCradles :: IO [(String, CradleConfig b)]
canonicalizeCradles =
      ((String, CradleConfig b) -> Down String)
-> [(String, CradleConfig b)] -> [(String, CradleConfig b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String -> Down String
forall a. a -> Down a
Down (String -> Down String)
-> ((String, CradleConfig b) -> String)
-> (String, CradleConfig b)
-> Down String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, CradleConfig b) -> String
forall a b. (a, b) -> a
fst)
        ([(String, CradleConfig b)] -> [(String, CradleConfig b)])
-> IO [(String, CradleConfig b)] -> IO [(String, CradleConfig b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, CradleConfig b) -> IO (String, CradleConfig b))
-> [(String, CradleConfig b)] -> IO [(String, CradleConfig b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(String
p, CradleConfig b
c) -> (,CradleConfig b
c) (String -> (String, CradleConfig b))
-> IO String -> IO (String, CradleConfig b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute (String
cur_dir String -> String -> String
</> String
p)) [(String, CradleConfig b)]
cs

    selectCradle :: [(String, CradleConfig b)]
-> IO (CradleLoadResult ComponentOptions)
selectCradle [] =
      CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail ([String] -> ExitCode -> [String] -> CradleError
CradleError [] ExitCode
ExitSuccess [String]
err_msg))
    selectCradle ((String
p, CradleConfig b
c): [(String, CradleConfig b)]
css) =
        if String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
cur_fp
          then CradleAction a
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
runCradle
                  (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg ((b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
forall b a. (b -> Cradle a) -> (CradleConfig b, String) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
c, String
cur_dir)))
                  LogAction IO (WithSeverity Log)
l
                  String
cur_fp
          else [(String, CradleConfig b)]
-> IO (CradleLoadResult ComponentOptions)
selectCradle [(String, CradleConfig b)]
css


-------------------------------------------------------------------------

directCradle :: FilePath -> [String] -> Cradle a
directCradle :: String -> [String] -> Cradle a
directCradle String
wdir [String]
args =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir = String
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Direct
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LogAction IO (WithSeverity Log)
_ String
_ ->
            CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ([String] -> String -> [String] -> ComponentOptions
ComponentOptions ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
argDynamic) String
wdir []))
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath String
wdir
        }
    }

-------------------------------------------------------------------------


-- | Find a cradle by finding an executable `hie-bios` file which will
-- be executed to find the correct GHC options to use.
biosCradle :: FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> Cradle a
biosCradle :: String -> Callable -> Maybe Callable -> Maybe String -> Cradle a
biosCradle String
wdir Callable
biosCall Maybe Callable
biosDepsCall Maybe String
mbGhc =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir    = String
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Bios
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = String
-> Callable
-> Maybe Callable
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
biosAction String
wdir Callable
biosCall Maybe Callable
biosDepsCall
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> String
-> String -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd String
wdir (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"ghc" Maybe String
mbGhc) [String]
args String
""
        }
    }

biosWorkDir :: FilePath -> MaybeT IO FilePath
biosWorkDir :: String -> MaybeT IO String
biosWorkDir = (String -> Bool) -> String -> MaybeT IO String
findFileUpwards (String
".hie-bios" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==)

biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> IO [FilePath]
biosDepsAction :: LogAction IO (WithSeverity Log)
-> String -> Maybe Callable -> String -> IO [String]
biosDepsAction LogAction IO (WithSeverity Log)
l String
wdir (Just Callable
biosDepsCall) String
fp = do
  CreateProcess
biosDeps' <- Callable -> Maybe String -> IO CreateProcess
callableToProcess Callable
biosDepsCall (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
  (ExitCode
ex, [String]
sout, [String]
serr, [(String
_, Maybe [String]
args)]) <- [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
wdir CreateProcess
biosDeps'
  case ExitCode
ex of
    ExitFailure Int
_ ->  String -> IO [String]
forall a. HasCallStack => String -> a
error (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ (ExitCode, [String], [String]) -> String
forall a. Show a => a -> String
show (ExitCode
ex, [String]
sout, [String]
serr)
    ExitCode
ExitSuccess -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
args
biosDepsAction LogAction IO (WithSeverity Log)
_ String
_ Maybe Callable
Nothing String
_ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

biosAction
  :: FilePath
  -> Callable
  -> Maybe Callable
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> IO (CradleLoadResult ComponentOptions)
biosAction :: String
-> Callable
-> Maybe Callable
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
biosAction String
wdir Callable
bios Maybe Callable
bios_deps LogAction IO (WithSeverity Log)
l String
fp = do
  CreateProcess
bios' <- Callable -> Maybe String -> IO CreateProcess
callableToProcess Callable
bios (String -> Maybe String
forall a. a -> Maybe a
Just String
fp)
  (ExitCode
ex, [String]
_stdo, [String]
std, [(String
_, Maybe [String]
res),(String
_, Maybe [String]
mb_deps)]) <-
    [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output, String
hie_bios_deps] LogAction IO (WithSeverity Log)
l String
wdir CreateProcess
bios'

  [String]
deps <- case Maybe [String]
mb_deps of
    Just [String]
x  -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x
    Maybe [String]
Nothing -> LogAction IO (WithSeverity Log)
-> String -> Maybe Callable -> String -> IO [String]
biosDepsAction LogAction IO (WithSeverity Log)
l String
wdir Maybe Callable
bios_deps String
fp
        -- Output from the program should be written to the output file and
        -- delimited by newlines.
        -- Execute the bios action and add dependencies of the cradle.
        -- Removes all duplicates.
  CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleLoadResult ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ (ExitCode, [String], String, [String])
-> [String] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [String]
std, String
wdir, [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
res) [String]
deps

callableToProcess :: Callable -> Maybe String -> IO CreateProcess
callableToProcess :: Callable -> Maybe String -> IO CreateProcess
callableToProcess (Command String
shellCommand) Maybe String
file = do
  [(String, String)]
old_env <- IO [(String, String)]
getEnvironment
  CreateProcess -> IO CreateProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (CreateProcess -> IO CreateProcess)
-> CreateProcess -> IO CreateProcess
forall a b. (a -> b) -> a -> b
$ (String -> CreateProcess
shell String
shellCommand) { env :: Maybe [(String, String)]
env = ((String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
old_env) ((String, String) -> [(String, String)])
-> (String -> (String, String)) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) String
hie_bios_arg (String -> [(String, String)])
-> Maybe String -> Maybe [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
file }
callableToProcess (Program String
path) Maybe String
file = do
  String
canon_path <- String -> IO String
canonicalizePath String
path
  CreateProcess -> IO CreateProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (CreateProcess -> IO CreateProcess)
-> CreateProcess -> IO CreateProcess
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
proc String
canon_path (Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
file)

------------------------------------------------------------------------
-- |Cabal Cradle
-- Works for new-build by invoking `v2-repl`.
cabalCradle :: FilePath -> Maybe String -> Cradle a
cabalCradle :: String -> Maybe String -> Cradle a
cabalCradle String
wdir Maybe String
mc =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir    = String
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Cabal
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LogAction IO (WithSeverity Log)
l String
f -> CradleLoadResultT IO ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> (String -> CradleLoadResultT IO ComponentOptions)
-> String
-> IO (CradleLoadResult ComponentOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Maybe String
-> LogAction IO (WithSeverity Log)
-> String
-> CradleLoadResultT IO ComponentOptions
cabalAction String
wdir Maybe String
mc LogAction IO (WithSeverity Log)
l (String -> IO (CradleLoadResult ComponentOptions))
-> String -> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ String
f
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO String -> IO (CradleLoadResult String))
-> CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ do
            String
buildDir <- IO String -> CradleLoadResultT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> CradleLoadResultT IO String)
-> IO String -> CradleLoadResultT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
cabalBuildDir String
wdir
            -- Workaround for a cabal-install bug on 3.0.0.0:
            -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
            IO () -> CradleLoadResultT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
buildDir String -> String -> String
</> String
"tmp")
            -- Need to pass -v0 otherwise we get "resolving dependencies..."
            CreateProcess
cabalProc <- String -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess String
wdir String
"v2-exec" ([String] -> CradleLoadResultT IO CreateProcess)
-> [String] -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ [String
"ghc", String
"-v0", String
"--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
            CreateProcess -> String -> CradleLoadResultT IO String
readProcessWithCwd' CreateProcess
cabalProc String
""
        }
    }

-- | Execute a cabal process in our custom cache-build directory configured
-- with the custom ghc executable.
-- The created process has its working directory set to the given working directory.
--
-- Invokes the cabal process in the given directory.
-- Finds the appropriate @ghc@ version as a fallback and provides the path
-- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which
-- the custom ghc wrapper may use as a fallback if it can not respond to certain
-- queries, such as ghc version or location of the libdir.
cabalProcess :: FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess :: String -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess String
workDir String
command [String]
args = do
  (String, String)
ghcDirs <- String -> CradleLoadResultT IO (String, String)
cabalGhcDirs String
workDir
  [(String, String)]
newEnvironment <- IO [(String, String)] -> CradleLoadResultT IO [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(String, String)] -> CradleLoadResultT IO [(String, String)])
-> IO [(String, String)] -> CradleLoadResultT IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String, String) -> IO [(String, String)]
setupEnvironment (String, String)
ghcDirs
  CreateProcess
cabalProc <- IO CreateProcess -> CradleLoadResultT IO CreateProcess
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CreateProcess -> CradleLoadResultT IO CreateProcess)
-> IO CreateProcess -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ (String, String) -> IO CreateProcess
setupCabalCommand (String, String)
ghcDirs
  CreateProcess -> CradleLoadResultT IO CreateProcess
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> CradleLoadResultT IO CreateProcess)
-> CreateProcess -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ (CreateProcess
cabalProc
      { env :: Maybe [(String, String)]
env = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
newEnvironment
      , cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
workDir
      })
  where
    processEnvironment :: (FilePath, FilePath) -> [(String, String)]
    processEnvironment :: (String, String) -> [(String, String)]
processEnvironment (String
ghcBin, String
libdir) =
      [(String
hie_bios_ghc, String
ghcBin), (String
hie_bios_ghc_args,  String
"-B" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
libdir)]

    setupEnvironment :: (FilePath, FilePath) -> IO [(String, String)]
    setupEnvironment :: (String, String) -> IO [(String, String)]
setupEnvironment (String, String)
ghcDirs = do
      [(String, String)]
environment <- IO [(String, String)]
getCleanEnvironment
      [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String, String) -> [(String, String)]
processEnvironment (String, String)
ghcDirs [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
environment

    setupCabalCommand :: (FilePath, FilePath) -> IO CreateProcess
    setupCabalCommand :: (String, String) -> IO CreateProcess
setupCabalCommand (String
ghcBin, String
libdir) = do
      String
wrapper_fp <- GhcProc -> String -> IO String
withGhcWrapperTool (String
"ghc", []) String
workDir
      String
buildDir <- String -> IO String
cabalBuildDir String
workDir
      String
ghcPkgPath <- String -> String -> IO String
withGhcPkgTool String
ghcBin String
libdir
      let extraCabalArgs :: [String]
extraCabalArgs =
            [ String
"--builddir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildDir
            , String
command
            , String
"--with-compiler", String
wrapper_fp
            , String
"--with-hc-pkg", String
ghcPkgPath
            ]
      CreateProcess -> IO CreateProcess
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> IO CreateProcess)
-> CreateProcess -> IO CreateProcess
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
proc String
"cabal" ([String]
extraCabalArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args)

-- | Discovers the location of 'ghc-pkg' given the absolute path to 'ghc'
-- and its '$libdir' (obtainable by running @ghc --print-libdir@).
--
-- @'withGhcPkgTool' ghcPathAbs libdir@ guesses the location by looking at
-- the filename of 'ghcPathAbs' and expects that 'ghc-pkg' is right next to it,
-- which is guaranteed by the ghc build system. Most OS's follow this
-- convention.
--
-- On unix, there is a high-chance that the obtained 'ghc' location is the
-- "unwrapped" executable, e.g. the executable without a shim that specifies
-- the '$libdir' and other important constants.
-- As such, the executable 'ghc-pkg' is similarly without a wrapper shim and
-- is lacking certain constants such as 'global-package-db'. It is, therefore,
-- not suitable to pass in to other consumers, such as 'cabal'.
--
-- Here, we restore the wrapper-shims, if necessary, thus the returned filepath
-- can be passed to 'cabal' without further modifications.
withGhcPkgTool :: FilePath -> FilePath -> IO FilePath
withGhcPkgTool :: String -> String -> IO String
withGhcPkgTool String
ghcPathAbs String
libdir = do
  let ghcName :: String
ghcName = String -> String
takeFileName String
ghcPathAbs
      -- TODO: check for existence
      ghcPkgPath :: String
ghcPkgPath = String -> String
guessGhcPkgFromGhc String
ghcName
  if Bool
isWindows
    then String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ghcPkgPath
    else String -> IO String
withWrapperTool String
ghcPkgPath
  where
    ghcDir :: String
ghcDir = String -> String
takeDirectory String
ghcPathAbs

    guessGhcPkgFromGhc :: String -> String
guessGhcPkgFromGhc String
ghcName =
      let ghcPkgName :: Text
ghcPkgName = Text -> Text -> Text -> Text
T.replace Text
"ghc" Text
"ghc-pkg" (String -> Text
T.pack String
ghcName)
      in String
ghcDir String -> String -> String
</> Text -> String
T.unpack Text
ghcPkgName

    -- Only on unix, creates a wrapper script that's hopefully identical
    -- to the wrapper script 'ghc-pkg' usually comes with.
    --
    -- 'ghc-pkg' needs to know the 'global-package-db' location which is
    -- passed in via a wrapper shim that basically wraps 'ghc-pkg' and
    -- only passes in the correct 'global-package-db'.
    -- For an example on how the wrapper script is supposed to look like, take
    -- a look at @cat $(which ghc-pkg)@, assuming 'ghc-pkg' is on your $PATH.
    --
    -- If we used the raw executable, i.e. not wrapped in a shim, then 'cabal'
    -- can not use the given 'ghc-pkg'.
    withWrapperTool :: String -> IO String
withWrapperTool String
ghcPkg = do
      let globalPackageDb :: String
globalPackageDb = String
libdir String -> String -> String
</> String
"package.conf.d"
          -- This is the same as the wrapper-shims ghc-pkg usually comes with.
          contents :: String
contents = [String] -> String
unlines
            [ String
"#!/bin/sh"
            , [String] -> String
unwords [String
"exec", String -> String
escapeFilePath String
ghcPkg
                      , String
"--global-package-db", String -> String
escapeFilePath String
globalPackageDb
                      , String
"${1+\"$@\"}"
                      ]
            ]
          srcHash :: String
srcHash = Fingerprint -> String
forall a. Show a => a -> String
show (String -> Fingerprint
fingerprintString String
contents)
      String -> String -> (String -> IO ()) -> IO String
cacheFile String
"ghc-pkg" String
srcHash ((String -> IO ()) -> IO String) -> (String -> IO ()) -> IO String
forall a b. (a -> b) -> a -> b
$ \String
wrapperFp -> String -> String -> IO ()
writeFile String
wrapperFp String
contents

    -- Escape the filepath and trim excess newlines added by 'escapeArgs'
    escapeFilePath :: String -> String
escapeFilePath String
fp = String -> String
trimEnd (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
escapeArgs [String
fp]

-- | @'cabalCradleDependencies' rootDir componentDir@.
-- Compute the dependencies of the cabal cradle based
-- on the cradle root and the component directory.
--
-- Directory 'componentDir' is a sub-directory where we look for
-- package specific cradle dependencies, such as a '.cabal' file.
--
-- Found dependencies are relative to 'rootDir'.
cabalCradleDependencies :: FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies :: String -> String -> IO [String]
cabalCradleDependencies String
rootDir String
componentDir = do
    let relFp :: String
relFp = String -> String -> String
makeRelative String
rootDir String
componentDir
    [String]
cabalFiles' <- String -> IO [String]
findCabalFiles String
componentDir
    let cabalFiles :: [String]
cabalFiles = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
relFp String -> String -> String
</>) [String]
cabalFiles'
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalise ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
cabalFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"cabal.project", String
"cabal.project.local"]

-- |Find .cabal files in the given directory.
--
-- Might return multiple results, as we can not know in advance
-- which one is important to the user.
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles :: String -> IO [String]
findCabalFiles String
wdir = do
  [String]
dirContent <- String -> IO [String]
listDirectory String
wdir
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) [String]
dirContent


processCabalWrapperArgs :: [String] -> Maybe (FilePath, [String])
processCabalWrapperArgs :: [String] -> Maybe GhcProc
processCabalWrapperArgs [String]
args =
    case [String]
args of
        (String
dir: [String]
ghc_args) ->
            let final_args :: [String]
final_args =
                    [String] -> [String]
removeVerbosityOpts
                    ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
removeRTS
                    ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
removeInteractive [String]
ghc_args
            in GhcProc -> Maybe GhcProc
forall a. a -> Maybe a
Just (String
dir, [String]
final_args)
        [String]
_ -> Maybe GhcProc
forall a. Maybe a
Nothing

-- | GHC process information.
-- Consists of the filepath to the ghc executable and
-- arguments to the executable.
type GhcProc = (FilePath, [String])

-- | Generate a fake GHC that can be passed to cabal or stack
-- when run with --interactive, it will print out its
-- command-line arguments and exit
withGhcWrapperTool :: GhcProc -> FilePath -> IO FilePath
withGhcWrapperTool :: GhcProc -> String -> IO String
withGhcWrapperTool (String
mbGhc, [String]
ghcArgs) String
wdir = do
    let wrapperContents :: String
wrapperContents = if Bool
isWindows then String
cabalWrapperHs else String
cabalWrapper
        withExtension :: String -> String
withExtension String
fp = if Bool
isWindows then String
fp String -> String -> String
<.> String
"exe" else String
fp
        srcHash :: String
srcHash = Fingerprint -> String
forall a. Show a => a -> String
show (String -> Fingerprint
fingerprintString String
wrapperContents)
    String -> String -> (String -> IO ()) -> IO String
cacheFile (String -> String
withExtension String
"wrapper") String
srcHash ((String -> IO ()) -> IO String) -> (String -> IO ()) -> IO String
forall a b. (a -> b) -> a -> b
$ \String
wrapper_fp ->
      if Bool
isWindows
      then
        String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hie-bios" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
tmpDir -> do
          let wrapper_hs :: String
wrapper_hs = String
wrapper_fp String -> String -> String
-<.> String
"hs"
          String -> String -> IO ()
writeFile String
wrapper_hs String
wrapperContents
          let ghc :: CreateProcess
ghc = (String -> [String] -> CreateProcess
proc String
mbGhc ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$
                      [String]
ghcArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-rtsopts=ignore", String
"-outputdir", String
tmpDir, String
"-o", String
wrapper_fp, String
wrapper_hs])
                      { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
wdir }
          CreateProcess -> String -> IO String
readCreateProcess CreateProcess
ghc String
"" IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr
      else String -> String -> IO ()
writeFile String
wrapper_fp String
wrapperContents

-- | Create and cache a file in hie-bios's cache directory.
--
-- @'cacheFile' fpName srcHash populate@. 'fpName' is the pattern name of the
-- cached file you want to create. 'srcHash' is the hash that is appended to
-- the file pattern and is expected to change whenever you want to invalidate
-- the cache.
--
-- If the cached file's 'srcHash' changes, then a new file is created, but
-- the old cached file name will not be deleted.
--
-- If the file does not exist yet, 'populate' is invoked with cached file
-- location and it is expected that the caller persists the given filepath in
-- the File System.
cacheFile :: FilePath -> String -> (FilePath -> IO ()) -> IO FilePath
cacheFile :: String -> String -> (String -> IO ()) -> IO String
cacheFile String
fpName String
srcHash String -> IO ()
populate = do
  String
cacheDir <- String -> IO String
getCacheDir String
""
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cacheDir
  let newFpName :: String
newFpName = String
cacheDir String -> String -> String
</> (String -> String
dropExtensions String
fpName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
srcHash) String -> String -> String
<.> String -> String
takeExtensions String
fpName
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesFileExist String
newFpName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
populate String
newFpName
    String -> IO ()
setMode String
newFpName
  String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
newFpName
  where
    setMode :: String -> IO ()
setMode String
wrapper_fp = String -> FileMode -> IO ()
setFileMode String
wrapper_fp FileMode
accessModes

-- | Given the root directory, get the build dir we are using for cabal
-- In the `hie-bios` cache directory
cabalBuildDir :: FilePath -> IO FilePath
cabalBuildDir :: String -> IO String
cabalBuildDir String
workDir = do
  String
abs_work_dir <- String -> IO String
makeAbsolute String
workDir
  let dirHash :: String
dirHash = Fingerprint -> String
forall a. Show a => a -> String
show (String -> Fingerprint
fingerprintString String
abs_work_dir)
  String -> IO String
getCacheDir (String
"dist-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) (String -> String
takeBaseName String
abs_work_dir)String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
"-"String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
dirHash)

-- | Discover the location of the ghc binary 'cabal' is going to use together
-- with its libdir location.
-- The ghc executable is an absolute path, but not necessarily canonicalised
-- or normalised. Additionally, the ghc path returned is likely to be the raw
-- executable, i.e. without the usual wrapper shims on non-windows systems.
-- If you want to use the given ghc executable, you should invoke
-- 'withGhcWrapperTool'.
--
-- If cabal can not figure it out, a 'CradleError' is returned.
cabalGhcDirs :: FilePath -> CradleLoadResultT IO (FilePath, FilePath)
cabalGhcDirs :: String -> CradleLoadResultT IO (String, String)
cabalGhcDirs String
workDir = do
  String
libdir <- String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
workDir String
"cabal" [String
"exec", String
"-v0", String
"--", String
"ghc", String
"--print-libdir"] String
""
  String
exe <- String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
workDir String
"cabal"
      -- DON'T TOUCH THIS CODE
      -- This works with 'NoImplicitPrelude', with 'RebindableSyntax' and other shenanigans.
      -- @-package-env=-@ doesn't work with ghc prior 8.4.x
      [ String
"exec", String
"-v0", String
"--" , String
"ghc", String
"-package-env=-", String
"-ignore-dot-ghci", String
"-e"
      , String
"Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"
      ]
      String
""
  (String, String) -> CradleLoadResultT IO (String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String
trimEnd String
exe, String -> String
trimEnd String
libdir)

cabalAction
  :: FilePath
  -> Maybe String
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> CradleLoadResultT IO ComponentOptions
cabalAction :: String
-> Maybe String
-> LogAction IO (WithSeverity Log)
-> String
-> CradleLoadResultT IO ComponentOptions
cabalAction String
workDir Maybe String
mc LogAction IO (WithSeverity Log)
l String
fp = do
  let
    cabalCommand :: String
cabalCommand = String
"v2-repl"
    cabalArgs :: [String]
cabalArgs = [String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
fixTargetPath String
fp) Maybe String
mc]

  CreateProcess
cabalProc <- String -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess String
workDir String
cabalCommand [String]
cabalArgs CradleLoadResultT IO CreateProcess
-> (CradleError -> IO CradleError)
-> CradleLoadResultT IO CreateProcess
forall (m :: * -> *) a.
Monad m =>
CradleLoadResultT m a
-> (CradleError -> m CradleError) -> CradleLoadResultT m a
`modCradleError` \CradleError
err -> do
      [String]
deps <- String -> String -> IO [String]
cabalCradleDependencies String
workDir String
workDir
      CradleError -> IO CradleError
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleError -> IO CradleError) -> CradleError -> IO CradleError
forall a b. (a -> b) -> a -> b
$ CradleError
err { cradleErrorDependencies :: [String]
cradleErrorDependencies = CradleError -> [String]
cradleErrorDependencies CradleError
err [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
deps }

  (ExitCode
ex, [String]
output, [String]
stde, [(String
_, Maybe [String]
maybeArgs)]) <- IO (ExitCode, [String], [String], [(String, Maybe [String])])
-> CradleLoadResultT
     IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [String], [String], [(String, Maybe [String])])
 -> CradleLoadResultT
      IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
-> CradleLoadResultT
     IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
workDir CreateProcess
cabalProc
  let args :: [String]
args = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
maybeArgs

  let errorDetails :: [String]
errorDetails =
        [String
"Failed command: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CmdSpec -> String
prettyCmdSpec (CreateProcess -> CmdSpec
cmdspec CreateProcess
cabalProc)
        , [String] -> String
unlines [String]
output
        , [String] -> String
unlines [String]
stde
        , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
args
        , String
"Process Environment:"]
        [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> CreateProcess -> [String]
prettyProcessEnv CreateProcess
cabalProc

  Bool -> CradleLoadResultT IO () -> CradleLoadResultT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ex ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (CradleLoadResultT IO () -> CradleLoadResultT IO ())
-> CradleLoadResultT IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [String]
deps <- IO [String] -> CradleLoadResultT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> CradleLoadResultT IO [String])
-> IO [String] -> CradleLoadResultT IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO [String]
cabalCradleDependencies String
workDir String
workDir
    let cmd :: String
cmd = [String] -> String
forall a. Show a => a -> String
show ([String
"cabal", String
cabalCommand] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
cabalArgs)
    let errorMsg :: String
errorMsg = String
"Failed to run " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in directory \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
workDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\". Consult the logs for full command and error."
    CradleError -> CradleLoadResultT IO ()
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE ([String] -> ExitCode -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex ([String
errorMsg] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
errorDetails))

  case [String] -> Maybe GhcProc
processCabalWrapperArgs [String]
args of
    Maybe GhcProc
Nothing -> do
      -- Provide some dependencies an IDE can look for to trigger a reload.
      -- Best effort. Assume the working directory is the
      -- root of the component, so we are right in trivial cases at least.
      [String]
deps <- IO [String] -> CradleLoadResultT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> CradleLoadResultT IO [String])
-> IO [String] -> CradleLoadResultT IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO [String]
cabalCradleDependencies String
workDir String
workDir
      CradleError -> CradleLoadResultT IO ComponentOptions
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE ([String] -> ExitCode -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex ([String] -> CradleError) -> [String] -> CradleError
forall a b. (a -> b) -> a -> b
$
                ([String
"Failed to parse result of calling cabal" ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
errorDetails))
    Just (String
componentDir, [String]
final_args) -> do
      [String]
deps <- IO [String] -> CradleLoadResultT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> CradleLoadResultT IO [String])
-> IO [String] -> CradleLoadResultT IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> IO [String]
cabalCradleDependencies String
workDir String
componentDir
      IO (CradleLoadResult ComponentOptions)
-> CradleLoadResultT IO ComponentOptions
forall (m :: * -> *) a.
m (CradleLoadResult a) -> CradleLoadResultT m a
CradleLoadResultT (IO (CradleLoadResult ComponentOptions)
 -> CradleLoadResultT IO ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
-> CradleLoadResultT IO ComponentOptions
forall a b. (a -> b) -> a -> b
$ CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ (ExitCode, [String], String, [String])
-> [String] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [String]
stde, String
componentDir, [String]
final_args) [String]
deps
  where
    -- Need to make relative on Windows, due to a Cabal bug with how it
    -- parses file targets with a C: drive in it
    fixTargetPath :: String -> String
fixTargetPath String
x
      | Bool
isWindows Bool -> Bool -> Bool
&& String -> Bool
hasDrive String
x = String -> String -> String
makeRelative String
workDir String
x
      | Bool
otherwise = String
x

removeInteractive :: [String] -> [String]
removeInteractive :: [String] -> [String]
removeInteractive = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"--interactive")

-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
data InRTS = OutsideRTS | InsideRTS

-- | Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
--
-- >>> removeRTS ["option1", "+RTS -H32m -RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS", "-H32m", "-RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS -H32m"]
-- ["option1"]
--
-- >>> removeRTS ["option1", "+RTS -H32m", "-RTS", "option2"]
-- ["option1", "option2"]
--
-- >>> removeRTS ["option1", "+RTS -H32m", "-H32m -RTS", "option2"]
-- ["option1", "option2"]
removeRTS :: [String] -> [String]
removeRTS :: [String] -> [String]
removeRTS = InRTS -> [String] -> [String]
go InRTS
OutsideRTS
  where
    go :: InRTS -> [String] -> [String]
    go :: InRTS -> [String] -> [String]
go InRTS
_ [] = []
    go InRTS
OutsideRTS (String
y:[String]
ys)
      | String
"+RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
y = InRTS -> [String] -> [String]
go (if String
"-RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
y then InRTS
OutsideRTS else InRTS
InsideRTS) [String]
ys
      | Bool
otherwise = String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: InRTS -> [String] -> [String]
go InRTS
OutsideRTS [String]
ys
    go InRTS
InsideRTS (String
y:[String]
ys) = InRTS -> [String] -> [String]
go (if String
"-RTS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
y then InRTS
OutsideRTS else InRTS
InsideRTS) [String]
ys


removeVerbosityOpts :: [String] -> [String]
removeVerbosityOpts :: [String] -> [String]
removeVerbosityOpts = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (String -> Bool) -> String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-v0") (String -> Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-w"))


cabalWorkDir :: FilePath -> MaybeT IO FilePath
cabalWorkDir :: String -> MaybeT IO String
cabalWorkDir String
wdir =
      (String -> Bool) -> String -> MaybeT IO String
findFileUpwards (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cabal.project") String
wdir
  MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Bool) -> String -> MaybeT IO String
findFileUpwards (\String
fp -> String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal") String
wdir

------------------------------------------------------------------------

-- | Explicit data-type for stack.yaml configuration location.
-- It is basically a 'Maybe' type, but helps to document the API
-- and helps to avoid incorrect usage.
data StackYaml
  = NoExplicitYaml
  | ExplicitYaml FilePath

-- | Create an explicit StackYaml configuration from the
stackYamlFromMaybe :: FilePath -> Maybe FilePath -> StackYaml
stackYamlFromMaybe :: String -> Maybe String -> StackYaml
stackYamlFromMaybe String
_wdir Maybe String
Nothing = StackYaml
NoExplicitYaml
stackYamlFromMaybe String
wdir (Just String
fp) = String -> StackYaml
ExplicitYaml (String
wdir String -> String -> String
</> String
fp)

stackYamlProcessArgs :: StackYaml -> [String]
stackYamlProcessArgs :: StackYaml -> [String]
stackYamlProcessArgs (ExplicitYaml String
yaml) = [String
"--stack-yaml", String
yaml]
stackYamlProcessArgs StackYaml
NoExplicitYaml = []

stackYamlLocationOrDefault :: StackYaml -> FilePath
stackYamlLocationOrDefault :: StackYaml -> String
stackYamlLocationOrDefault StackYaml
NoExplicitYaml = String
"stack.yaml"
stackYamlLocationOrDefault (ExplicitYaml String
yaml) = String
yaml

-- | Stack Cradle
-- Works for by invoking `stack repl` with a wrapper script
stackCradle :: FilePath -> Maybe String -> StackYaml -> Cradle a
stackCradle :: String -> Maybe String -> StackYaml -> Cradle a
stackCradle String
wdir Maybe String
mc StackYaml
syaml =
  Cradle :: forall a. String -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: String
cradleRootDir    = String
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LogAction IO (WithSeverity Log)
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Stack
        , runCradle :: LogAction IO (WithSeverity Log)
-> String -> IO (CradleLoadResult ComponentOptions)
runCradle = String
-> Maybe String
-> StackYaml
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
stackAction String
wdir Maybe String
mc StackYaml
syaml
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO String -> IO (CradleLoadResult String))
-> CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ do
            -- Setup stack silently, since stack might print stuff to stdout in some cases (e.g. on Win)
            -- Issue 242 from HLS: https://github.com/haskell/haskell-language-server/issues/242
            String
_ <- String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
wdir String
"stack" (StackYaml -> [String]
stackYamlProcessArgs StackYaml
syaml [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"setup", String
"--silent"]) String
""
            String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
wdir String
"stack"
              (StackYaml -> [String]
stackYamlProcessArgs StackYaml
syaml [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"exec", String
"ghc", String
"--"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
args)
              String
""
        }
    }

-- | @'stackCradleDependencies' rootDir componentDir@.
-- Compute the dependencies of the stack cradle based
-- on the cradle root and the component directory.
--
-- Directory 'componentDir' is a sub-directory where we look for
-- package specific cradle dependencies, such as 'package.yaml' and
-- a '.cabal' file.
--
-- Found dependencies are relative to 'rootDir'.
stackCradleDependencies :: FilePath -> FilePath -> StackYaml -> IO [FilePath]
stackCradleDependencies :: String -> String -> StackYaml -> IO [String]
stackCradleDependencies String
wdir String
componentDir StackYaml
syaml = do
  let relFp :: String
relFp = String -> String -> String
makeRelative String
wdir String
componentDir
  [String]
cabalFiles' <- String -> IO [String]
findCabalFiles String
componentDir
  let cabalFiles :: [String]
cabalFiles = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
relFp String -> String -> String
</>) [String]
cabalFiles'
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalise ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    [String]
cabalFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
relFp String -> String -> String
</> String
"package.yaml", StackYaml -> String
stackYamlLocationOrDefault StackYaml
syaml]

stackAction
  :: FilePath
  -> Maybe String
  -> StackYaml
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> IO (CradleLoadResult ComponentOptions)
stackAction :: String
-> Maybe String
-> StackYaml
-> LogAction IO (WithSeverity Log)
-> String
-> IO (CradleLoadResult ComponentOptions)
stackAction String
workDir Maybe String
mc StackYaml
syaml LogAction IO (WithSeverity Log)
l String
_fp = do
  let ghcProcArgs :: GhcProc
ghcProcArgs = (String
"stack", StackYaml -> [String]
stackYamlProcessArgs StackYaml
syaml [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"exec", String
"ghc", String
"--"])
  -- Same wrapper works as with cabal
  String
wrapper_fp <- GhcProc -> String -> IO String
withGhcWrapperTool GhcProc
ghcProcArgs String
workDir
  (ExitCode
ex1, [String]
_stdo, [String]
stde, [(String
_, Maybe [String]
maybeArgs)]) <-
    [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
workDir (CreateProcess
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$
    StackYaml -> [String] -> CreateProcess
stackProcess StackYaml
syaml
                ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$  [String
"repl", String
"--no-nix-pure", String
"--with-ghc", String
wrapper_fp]
                    [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ String
comp | Just String
comp <- [Maybe String
mc] ]
  (ExitCode
ex2, [String]
pkg_args, [String]
stdr, [(String, Maybe [String])]
_) <-
    [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
workDir (CreateProcess
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$
      StackYaml -> [String] -> CreateProcess
stackProcess StackYaml
syaml [String
"path", String
"--ghc-package-path"]
  let split_pkgs :: [String]
split_pkgs = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
splitSearchPath [String]
pkg_args
      pkg_ghc_args :: [String]
pkg_ghc_args = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
p -> [String
"-package-db", String
p] ) [String]
split_pkgs
      args :: [String]
args = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
maybeArgs
  case [String] -> Maybe GhcProc
processCabalWrapperArgs [String]
args of
      Maybe GhcProc
Nothing -> do
        -- Best effort. Assume the working directory is the
        -- the root of the component, so we are right in trivial cases at least.
        [String]
deps <- String -> String -> StackYaml -> IO [String]
stackCradleDependencies String
workDir String
workDir StackYaml
syaml
        CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail
                  ([String] -> ExitCode -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex1 ([String] -> CradleError) -> [String] -> CradleError
forall a b. (a -> b) -> a -> b
$
                    [ String
"Failed to parse result of calling stack" ]
                    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stde
                    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
                  )

      Just (String
componentDir, [String]
ghc_args) -> do
        [String]
deps <- String -> String -> StackYaml -> IO [String]
stackCradleDependencies String
workDir String
componentDir StackYaml
syaml
        CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ (ExitCode, [String], String, [String])
-> [String] -> CradleLoadResult ComponentOptions
makeCradleResult
                  ( [ExitCode] -> ExitCode
combineExitCodes [ExitCode
ex1, ExitCode
ex2]
                  , [String]
stde [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
stdr, String
componentDir
                  , [String]
ghc_args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_ghc_args
                  )
                  [String]
deps

stackProcess :: StackYaml -> [String] -> CreateProcess
stackProcess :: StackYaml -> [String] -> CreateProcess
stackProcess StackYaml
syaml [String]
args = String -> [String] -> CreateProcess
proc String
"stack" ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ StackYaml -> [String]
stackYamlProcessArgs StackYaml
syaml [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
args

combineExitCodes :: [ExitCode] -> ExitCode
combineExitCodes :: [ExitCode] -> ExitCode
combineExitCodes = (ExitCode -> ExitCode -> ExitCode)
-> ExitCode -> [ExitCode] -> ExitCode
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ExitCode -> ExitCode -> ExitCode
go ExitCode
ExitSuccess
  where
    go :: ExitCode -> ExitCode -> ExitCode
go ExitCode
ExitSuccess ExitCode
b = ExitCode
b
    go ExitCode
a ExitCode
_ = ExitCode
a

stackExecutable :: MaybeT IO FilePath
stackExecutable :: MaybeT IO String
stackExecutable = IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
"stack"

stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir :: String -> MaybeT IO String
stackWorkDir = (String -> Bool) -> String -> MaybeT IO String
findFileUpwards String -> Bool
forall a. (Eq a, IsString a) => a -> Bool
isStack
  where
    isStack :: a -> Bool
isStack a
name = a
name a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"stack.yaml"

{-
-- Support removed for 0.3 but should be added back in the future
----------------------------------------------------------------------------
-- rules_haskell - Thanks for David Smith for helping with this one.
-- Looks for the directory containing a WORKSPACE file
--
rulesHaskellWorkDir :: FilePath -> MaybeT IO FilePath
rulesHaskellWorkDir fp =
  findFileUpwards (== "WORKSPACE") fp

rulesHaskellCradle :: FilePath -> Cradle
rulesHaskellCradle wdir =
  Cradle
    { cradleRootDir  = wdir
    , cradleOptsProg   = CradleAction
        { actionName = "bazel"
        , runCradle = rulesHaskellAction wdir
        }
    }

rulesHaskellCradleDependencies :: FilePath -> IO [FilePath]
rulesHaskellCradleDependencies _wdir = return ["BUILD.bazel", "WORKSPACE"]

bazelCommand :: String
bazelCommand = $(embedStringFile "wrappers/bazel")

rulesHaskellAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions)
rulesHaskellAction workDir fp = do
  wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand
  setFileMode wrapper_fp accessModes
  let rel_path = makeRelative workDir fp
  (ex, args, stde) <-
      readProcessWithOutputFile workDir wrapper_fp [rel_path] []
  let args'  = filter (/= '\'') args
  let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')
  deps <- rulesHaskellCradleDependencies workDir
  return $ makeCradleResult (ex, stde, args'') deps


------------------------------------------------------------------------------
-- Obelisk Cradle
-- Searches for the directory which contains `.obelisk`.

obeliskWorkDir :: FilePath -> MaybeT IO FilePath
obeliskWorkDir fp = do
  -- Find a possible root which will contain the cabal.project
  wdir <- findFileUpwards (== "cabal.project") fp
  -- Check for the ".obelisk" folder in this directory
  check <- liftIO $ doesDirectoryExist (wdir </> ".obelisk")
  unless check (fail "Not obelisk dir")
  return wdir

obeliskCradleDependencies :: FilePath -> IO [FilePath]
obeliskCradleDependencies _wdir = return []

obeliskCradle :: FilePath -> Cradle
obeliskCradle wdir =
  Cradle
    { cradleRootDir  = wdir
    , cradleOptsProg = CradleAction
        { actionName = "obelisk"
        , runCradle = obeliskAction wdir
        }
    }

obeliskAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions)
obeliskAction workDir _fp = do
  (ex, args, stde) <-
      readProcessWithOutputFile workDir "ob" ["ide-args"] []

  o_deps <- obeliskCradleDependencies workDir
  return (makeCradleResult (ex, stde, words args) o_deps )

-}
------------------------------------------------------------------------------
-- Utilities


-- | Searches upwards for the first directory containing a file to match
-- the predicate.
findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards :: (String -> Bool) -> String -> MaybeT IO String
findFileUpwards String -> Bool
p String
dir = do
  [String]
cnts <-
    IO [String] -> MaybeT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO [String] -> MaybeT IO [String])
-> IO [String] -> MaybeT IO [String]
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe [String])
-> ([String] -> IO [String]) -> IO [String] -> IO [String]
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust
        -- Catch permission errors
        (\(IOError
e :: IOError) -> if IOError -> Bool
isPermissionError IOError
e then [String] -> Maybe [String]
forall a. a -> Maybe a
Just [] else Maybe [String]
forall a. Maybe a
Nothing)
        [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ((String -> Bool) -> String -> IO [String]
findFile String -> Bool
p String
dir)

  case [String]
cnts of
    [] | String
dir' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dir -> String -> MaybeT IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No cabal files"
            | Bool
otherwise   -> (String -> Bool) -> String -> MaybeT IO String
findFileUpwards String -> Bool
p String
dir'
    String
_ : [String]
_ -> String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
  where dir' :: String
dir' = String -> String
takeDirectory String
dir

-- | Sees if any file in the directory matches the predicate
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile :: (String -> Bool) -> String -> IO [String]
findFile String -> Bool
p String
dir = do
  Bool
b <- String -> IO Bool
doesDirectoryExist String
dir
  if Bool
b then IO [String]
getFiles IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesPredFileExist else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    getFiles :: IO [String]
getFiles = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
p ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
dir
    doesPredFileExist :: String -> IO Bool
doesPredFileExist String
file = String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
file

-- | Some environments (e.g. stack exec) include GHC_PACKAGE_PATH.
-- Cabal v2 *will* complain, even though or precisely because it ignores them.
-- Unset them from the environment to sidestep this
getCleanEnvironment :: IO [(String, String)]
getCleanEnvironment :: IO [(String, String)]
getCleanEnvironment = do
  HashMap String String -> [(String, String)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap String String -> [(String, String)])
-> ([(String, String)] -> HashMap String String)
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HashMap String String -> HashMap String String
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete String
"GHC_PACKAGE_PATH" (HashMap String String -> HashMap String String)
-> ([(String, String)] -> HashMap String String)
-> [(String, String)]
-> HashMap String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> HashMap String String
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment

type Outputs = [OutputName]
type OutputName = String

-- | Call a given process with temp files for the process to write to.
-- * The process can discover the temp files paths by reading the environment.
-- * The contents of the temp files are returned by this function, if any.
-- * The logging function is called every time the process emits anything to stdout or stderr.
-- it can be used to report progress of the process to a user.
-- * The process is executed in the given directory.
readProcessWithOutputs
  :: Outputs  -- ^ Names of the outputs produced by this process
  -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs.
  -> FilePath -- ^ Working directory. Process is executed in this directory.
  -> CreateProcess -- ^ Parameters for the process to be executed.
  -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])])
readProcessWithOutputs :: [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String]
outputNames LogAction IO (WithSeverity Log)
l String
workDir CreateProcess
cp = (ContT
   (ExitCode, [String], [String], [(String, Maybe [String])])
   IO
   (ExitCode, [String], [String], [(String, Maybe [String])])
 -> ((ExitCode, [String], [String], [(String, Maybe [String])])
     -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> ((ExitCode, [String], [String], [(String, Maybe [String])])
    -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (ExitCode, [String], [String], [(String, Maybe [String])])
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContT
  (ExitCode, [String], [String], [(String, Maybe [String])])
  IO
  (ExitCode, [String], [String], [(String, Maybe [String])])
-> ((ExitCode, [String], [String], [(String, Maybe [String])])
    -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (ExitCode, [String], [String], [(String, Maybe [String])])
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall (m :: * -> *) a. Monad m => a -> m a
return (ContT
   (ExitCode, [String], [String], [(String, Maybe [String])])
   IO
   (ExitCode, [String], [String], [(String, Maybe [String])])
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (ExitCode, [String], [String], [(String, Maybe [String])])
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ do
  [(String, String)]
old_env <- IO [(String, String)]
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getCleanEnvironment
  [(String, String)]
output_files <- (String
 -> ContT
      (ExitCode, [String], [String], [(String, Maybe [String])])
      IO
      (String, String))
-> [String]
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     [(String, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([(String, String)]
-> String
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (String, String)
forall a.
[(String, String)] -> String -> ContT a IO (String, String)
withOutput [(String, String)]
old_env) [String]
outputNames

  let process :: CreateProcess
process = CreateProcess
cp { env :: Maybe [(String, String)]
env = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just ([(String, String)] -> Maybe [(String, String)])
-> [(String, String)] -> Maybe [(String, String)]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
output_files [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
-> Maybe [(String, String)] -> [(String, String)]
forall a. a -> Maybe a -> a
fromMaybe [(String, String)]
old_env (CreateProcess -> Maybe [(String, String)]
env CreateProcess
cp),
                     cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
workDir
                    }

    -- Windows line endings are not converted so you have to filter out `'r` characters
  let loggingConduit :: ConduitM ByteString c IO [String]
loggingConduit = ConduitT ByteString Text IO ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
C.decodeUtf8  ConduitT ByteString Text IO ()
-> ConduitM Text c IO [String] -> ConduitM ByteString c IO [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| ConduitT Text Text IO ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
C.lines ConduitT Text Text IO ()
-> ConduitM Text c IO [String] -> ConduitM Text c IO [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| (Element Text -> Bool) -> ConduitT Text Text IO ()
forall seq (m :: * -> *).
(IsSequence seq, Monad m) =>
(Element seq -> Bool) -> ConduitT seq seq m ()
C.filterE (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')
        ConduitT Text Text IO ()
-> ConduitM Text c IO [String] -> ConduitM Text c IO [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| (Text -> String) -> ConduitT Text String IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
C.map Text -> String
T.unpack ConduitT Text String IO ()
-> ConduitM String c IO [String] -> ConduitM Text c IO [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| (String -> IO ()) -> ConduitT String String IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ConduitT a a m ()
C.iterM (\String
msg -> LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String -> Log
LogProcessOutput String
msg Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug) ConduitT String String IO ()
-> ConduitM String c IO [String] -> ConduitM String c IO [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| ConduitM String c IO [String]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
C.sinkList
  (ExitCode
ex, [String]
stdo, [String]
stde) <- IO (ExitCode, [String], [String])
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (ExitCode, [String], [String])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [String], [String])
 -> ContT
      (ExitCode, [String], [String], [(String, Maybe [String])])
      IO
      (ExitCode, [String], [String]))
-> IO (ExitCode, [String], [String])
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (ExitCode, [String], [String])
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO [String]
-> ConduitT ByteString Void IO [String]
-> IO (ExitCode, [String], [String])
forall (m :: * -> *) a b.
MonadUnliftIO m =>
CreateProcess
-> ConduitT () ByteString m ()
-> ConduitT ByteString Void m a
-> ConduitT ByteString Void m b
-> m (ExitCode, a, b)
sourceProcessWithStreams CreateProcess
process ConduitT () ByteString IO ()
forall a. Monoid a => a
mempty ConduitT ByteString Void IO [String]
forall c. ConduitM ByteString c IO [String]
loggingConduit ConduitT ByteString Void IO [String]
forall c. ConduitM ByteString c IO [String]
loggingConduit

  [(String, Maybe [String])]
res <- [(String, String)]
-> ((String, String)
    -> ContT
         (ExitCode, [String], [String], [(String, Maybe [String])])
         IO
         (String, Maybe [String]))
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     [(String, Maybe [String])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
output_files (((String, String)
  -> ContT
       (ExitCode, [String], [String], [(String, Maybe [String])])
       IO
       (String, Maybe [String]))
 -> ContT
      (ExitCode, [String], [String], [(String, Maybe [String])])
      IO
      [(String, Maybe [String])])
-> ((String, String)
    -> ContT
         (ExitCode, [String], [String], [(String, Maybe [String])])
         IO
         (String, Maybe [String]))
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     [(String, Maybe [String])]
forall a b. (a -> b) -> a -> b
$ \(String
name,String
path) ->
          IO (String, Maybe [String])
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (String, Maybe [String])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, Maybe [String])
 -> ContT
      (ExitCode, [String], [String], [(String, Maybe [String])])
      IO
      (String, Maybe [String]))
-> IO (String, Maybe [String])
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (String, Maybe [String])
forall a b. (a -> b) -> a -> b
$ (String
name,) (Maybe [String] -> (String, Maybe [String]))
-> IO (Maybe [String]) -> IO (String, Maybe [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe [String])
readOutput String
path

  (ExitCode, [String], [String], [(String, Maybe [String])])
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     (ExitCode, [String], [String], [(String, Maybe [String])])
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, [String]
stdo, [String]
stde, [(String, Maybe [String])]
res)

    where
      readOutput :: FilePath -> IO (Maybe [String])
      readOutput :: String -> IO (Maybe [String])
readOutput String
path = do
        Bool
haveFile <- String -> IO Bool
doesFileExist String
path
        if Bool
haveFile
          then String
-> IOMode -> (Handle -> IO (Maybe [String])) -> IO (Maybe [String])
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode ((Handle -> IO (Maybe [String])) -> IO (Maybe [String]))
-> (Handle -> IO (Maybe [String])) -> IO (Maybe [String])
forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
            Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering
            !String
res <- String -> String
forall a. NFData a => a -> a
force (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO String
hGetContents Handle
handle
            Maybe [String] -> IO (Maybe [String])
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] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') String
res
          else
            Maybe [String] -> IO (Maybe [String])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [String]
forall a. Maybe a
Nothing

      withOutput :: [(String,String)] -> OutputName -> ContT a IO (OutputName, String)
      withOutput :: [(String, String)] -> String -> ContT a IO (String, String)
withOutput [(String, String)]
env' String
name =
        case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, String)]
env' of
          Just file :: String
file@(Char
_:String
_) -> (((String, String) -> IO a) -> IO a) -> ContT a IO (String, String)
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((String, String) -> IO a) -> IO a)
 -> ContT a IO (String, String))
-> (((String, String) -> IO a) -> IO a)
-> ContT a IO (String, String)
forall a b. (a -> b) -> a -> b
$ \(String, String) -> IO a
action -> do
            String -> IO ()
removeFileIfExists String
file
            (String, String) -> IO a
action (String
name, String
file)
          Maybe String
_ -> (((String, String) -> IO a) -> IO a) -> ContT a IO (String, String)
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((String, String) -> IO a) -> IO a)
 -> ContT a IO (String, String))
-> (((String, String) -> IO a) -> IO a)
-> ContT a IO (String, String)
forall a b. (a -> b) -> a -> b
$ \(String, String) -> IO a
action -> String -> (String -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
name ((String -> Handle -> IO a) -> IO a)
-> (String -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ String
file Handle
h -> do
            Handle -> IO ()
hClose Handle
h
            String -> IO ()
removeFileIfExists String
file
            (String, String) -> IO a
action (String
name, String
file)

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists :: String -> IO ()
removeFileIfExists String
f = do
  Bool
yes <- String -> IO Bool
doesFileExist String
f
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
yes (String -> IO ()
removeFile String
f)

makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult :: (ExitCode, [String], String, [String])
-> [String] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [String]
err, String
componentDir, [String]
gopts) [String]
deps =
  case ExitCode
ex of
    ExitFailure Int
_ -> CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail ([String] -> ExitCode -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex [String]
err)
    ExitCode
_ ->
        let compOpts :: ComponentOptions
compOpts = [String] -> String -> [String] -> ComponentOptions
ComponentOptions [String]
gopts String
componentDir [String]
deps
        in ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ComponentOptions
compOpts

-- | Calls @ghc --print-libdir@, with just whatever's on the PATH.
runGhcCmdOnPath :: FilePath -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath :: String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath String
wdir [String]
args = String
-> String -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd String
wdir String
"ghc" [String]
args String
""
  -- case mResult of
  --   Nothing

-- | Wrapper around 'readCreateProcess' that sets the working directory and
-- clears the environment, suitable for invoking cabal/stack and raw ghc commands.
readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd :: String
-> String -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd String
dir String
cmd [String]
args String
stdin = CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO String -> IO (CradleLoadResult String))
-> CradleLoadResultT IO String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
dir String
cmd [String]
args String
stdin

readProcessWithCwd_ :: FilePath -> FilePath -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ :: String
-> String -> [String] -> String -> CradleLoadResultT IO String
readProcessWithCwd_ String
dir String
cmd [String]
args String
stdin = do
  [(String, String)]
cleanEnv <- IO [(String, String)] -> CradleLoadResultT IO [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getCleanEnvironment
  let createProc :: CreateProcess
createProc = (String -> [String] -> CreateProcess
proc String
cmd [String]
args) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
dir, env :: Maybe [(String, String)]
env = [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
cleanEnv }
  CreateProcess -> String -> CradleLoadResultT IO String
readProcessWithCwd' CreateProcess
createProc String
stdin

-- | Wrapper around 'readCreateProcessWithExitCode', wrapping the result in
-- a 'CradleLoadResult'. Provides better error messages than raw 'readCreateProcess'.
readProcessWithCwd' :: CreateProcess -> String -> CradleLoadResultT IO String
readProcessWithCwd' :: CreateProcess -> String -> CradleLoadResultT IO String
readProcessWithCwd' CreateProcess
createdProcess String
stdin = do
  Maybe (ExitCode, String, String)
mResult <- IO (Maybe (ExitCode, String, String))
-> CradleLoadResultT IO (Maybe (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ExitCode, String, String))
 -> CradleLoadResultT IO (Maybe (ExitCode, String, String)))
-> IO (Maybe (ExitCode, String, String))
-> CradleLoadResultT IO (Maybe (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ IO (ExitCode, String, String)
-> IO (Maybe (ExitCode, String, String))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (IO (ExitCode, String, String)
 -> IO (Maybe (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Maybe (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
createdProcess String
stdin
  let cmdString :: String
cmdString = CmdSpec -> String
prettyCmdSpec (CmdSpec -> String) -> CmdSpec -> String
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
createdProcess
  case Maybe (ExitCode, String, String)
mResult of
    Just (ExitCode
ExitSuccess, String
stdo, String
_) -> String -> CradleLoadResultT IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stdo
    Just (ExitCode
exitCode, String
stdo, String
stde) -> CradleError -> CradleLoadResultT IO String
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE (CradleError -> CradleLoadResultT IO String)
-> CradleError -> CradleLoadResultT IO String
forall a b. (a -> b) -> a -> b
$
      [String] -> ExitCode -> [String] -> CradleError
CradleError [] ExitCode
exitCode ([String] -> CradleError) -> [String] -> CradleError
forall a b. (a -> b) -> a -> b
$
        [String
"Error when calling " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmdString, String
stdo, String
stde] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> CreateProcess -> [String]
prettyProcessEnv CreateProcess
createdProcess
    Maybe (ExitCode, String, String)
Nothing -> CradleError -> CradleLoadResultT IO String
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE (CradleError -> CradleLoadResultT IO String)
-> CradleError -> CradleLoadResultT IO String
forall a b. (a -> b) -> a -> b
$
      [String] -> ExitCode -> [String] -> CradleError
CradleError [] ExitCode
ExitSuccess ([String] -> CradleError) -> [String] -> CradleError
forall a b. (a -> b) -> a -> b
$
        [String
"Couldn't execute " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmdString] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> CreateProcess -> [String]
prettyProcessEnv CreateProcess
createdProcess

-- | Prettify 'CmdSpec', so we can show the command to a user
prettyCmdSpec :: CmdSpec -> String
prettyCmdSpec :: CmdSpec -> String
prettyCmdSpec (ShellCommand String
s) = String
s
prettyCmdSpec (RawCommand String
cmd [String]
args) = String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args

-- | Pretty print hie-bios's relevant environment variables.
prettyProcessEnv :: CreateProcess -> [String]
prettyProcessEnv :: CreateProcess -> [String]
prettyProcessEnv CreateProcess
p =
  [ String
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
value
  | (String
key, String
value) <- [(String, String)]
-> Maybe [(String, String)] -> [(String, String)]
forall a. a -> Maybe a -> a
fromMaybe [] (CreateProcess -> Maybe [(String, String)]
env CreateProcess
p)
  , String
key String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String
hie_bios_output
               , String
hie_bios_ghc
               , String
hie_bios_ghc_args
               , String
hie_bios_arg
               , String
hie_bios_deps
               ]
  ]