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

import Control.Exception (handleJust)
import qualified Data.Yaml as Yaml
import Data.Void
import Data.Char (isSpace)
import Data.Bifunctor (first)
import System.Process
import System.Exit
import HIE.Bios.Types hiding (ActionName(..))
import qualified HIE.Bios.Types as Types
import HIE.Bios.Config
import HIE.Bios.Environment (getCacheDir)
import qualified HIE.Bios.Ghc.Gap as Gap
import System.Directory hiding (findFile)
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import System.FilePath
import Control.Monad
import System.Info.Extra
import Control.Monad.IO.Class
import System.Environment
import Control.Applicative ((<|>), optional)
import System.IO.Temp
import System.IO.Error (isPermissionError)
import Data.List
import Data.Ord (Down(..))

import System.PosixCompat.Files
import HIE.Bios.Wrappers
import System.IO
import Control.DeepSeq

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.Text as T
import qualified Data.HashMap.Strict as Map
import           Data.Maybe (fromMaybe, maybeToList)
import           GHC.Fingerprint (fingerprintString)

hie_bios_output :: String
hie_bios_output :: String
hie_bios_output = String
"HIE_BIOS_OUTPUT"
----------------------------------------------------------------

-- | 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 ((CradleConfig b, String) -> Cradle a)
-> (CradleConfig b, String) -> Cradle a
forall a b. (a -> b) -> a -> b
$
        ([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 ((CradleConfig b, String) -> Cradle a)
-> (CradleConfig b, String) -> Cradle a
forall a b. (a -> b) -> a -> b
$
        ([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 :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LoggingFunction
l String
fp ->
            CradleAction a
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
runCradle CradleAction a
ca LoggingFunction
l String
fp
              IO (CradleLoadResult ComponentOptions)
-> (CradleLoadResult ComponentOptions
    -> IO (CradleLoadResult ComponentOptions))
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                CradleSuccess (ComponentOptions [String]
os' String
dir [String]
ds) ->
                  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
$ 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))
                CradleFail CradleError
err ->
                  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
                    (CradleError
err { cradleErrorDependencies :: [String]
cradleErrorDependencies = CradleError -> [String]
cradleErrorDependencies CradleError
err [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` [String]
deps })
                CradleLoadResult ComponentOptions
CradleNone -> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CradleLoadResult ComponentOptions
forall r. CradleLoadResult r
CradleNone
         }

-- | 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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Default
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LoggingFunction
_ 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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.None
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LoggingFunction
_ 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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
multiActionName
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle  = \LoggingFunction
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)]
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
forall b a.
(b -> Cradle a)
-> String
-> [(String, CradleConfig b)]
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
multiAction b -> Cradle a
buildCustomCradle String
cur_dir [(String, CradleConfig b)]
cs LoggingFunction
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)]
            -> LoggingFunction
            -> FilePath
            -> IO (CradleLoadResult ComponentOptions)
multiAction :: (b -> Cradle a)
-> String
-> [(String, CradleConfig b)]
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
multiAction b -> Cradle a
buildCustomCradle String
cur_dir [(String, CradleConfig b)]
cs LoggingFunction
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
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> LoggingFunction
-> 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)))
                  LoggingFunction
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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Direct
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = \LoggingFunction
_ 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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Bios
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = String
-> Callable
-> Maybe Callable
-> LoggingFunction
-> 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 :: LoggingFunction -> FilePath -> Maybe Callable -> FilePath -> IO [FilePath]
biosDepsAction :: LoggingFunction
-> String -> Maybe Callable -> String -> IO [String]
biosDepsAction LoggingFunction
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]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LoggingFunction
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 LoggingFunction
_ String
_ Maybe Callable
Nothing String
_ = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

biosAction :: FilePath
           -> Callable
           -> Maybe Callable
           -> LoggingFunction
           -> FilePath
           -> IO (CradleLoadResult ComponentOptions)
biosAction :: String
-> Callable
-> Maybe Callable
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
biosAction String
wdir Callable
bios Maybe Callable
bios_deps LoggingFunction
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]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output, String
"HIE_BIOS_DEPS"] LoggingFunction
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 -> LoggingFunction
-> String -> Maybe Callable -> String -> IO [String]
biosDepsAction LoggingFunction
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,) String
hieBiosArg (String -> [(String, String)])
-> Maybe String -> Maybe [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
file }
    where
      hieBiosArg :: String
hieBiosArg = String
"HIE_BIOS_ARG"
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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Cabal
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = String
-> Maybe String
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
cabalAction String
wdir Maybe String
mc
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> do
            String
buildDir <- 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)
            Bool -> LoggingFunction
createDirectoryIfMissing Bool
True (String
buildDir String -> String -> String
</> String
"tmp")
            -- Need to pass -v0 otherwise we get "resolving dependencies..."
            String
wrapper_fp <- GhcProc -> String -> IO String
withCabalWrapperTool (String
"ghc", []) String
wdir
            String
-> String -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd
              String
wdir String
"cabal" ([String
"--builddir="String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
buildDir,String
"v2-exec",String
"--with-compiler", String
wrapper_fp, String
"ghc", String
"-v0", String
"--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) String
""
        }
    }

-- | @'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] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [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
-- when run with --interactive, it will print out its
-- command-line arguments and exit
withCabalWrapperTool :: GhcProc -> FilePath -> IO FilePath
withCabalWrapperTool :: GhcProc -> String -> IO String
withCabalWrapperTool (String
mbGhc, [String]
ghcArgs) String
wdir = do
    String
cacheDir <- String -> IO String
getCacheDir String
""
    Bool -> LoggingFunction
createDirectoryIfMissing Bool
True String
cacheDir
    let wrapperContents :: String
wrapperContents = if Bool
isWindows then String
cabalWrapperHs else String
cabalWrapper
        suffix :: String -> String
suffix String
fp = if Bool
isWindows then String
fp String -> String -> String
<.> String
"exe" else String
fp
    let srcHash :: String
srcHash = Fingerprint -> String
forall a. Show a => a -> String
show (String -> Fingerprint
fingerprintString String
wrapperContents)
    let wrapper_name :: String
wrapper_name = String
"wrapper-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcHash
    let wrapper_fp :: String
wrapper_fp = String -> String
suffix (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
cacheDir String -> String -> String
</> String
wrapper_name
    Bool
exists <- String -> IO Bool
doesFileExist String
wrapper_fp
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      if Bool
isWindows
      then do
        String -> LoggingFunction -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hie-bios" (LoggingFunction -> IO ()) -> LoggingFunction -> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
tmpDir -> do
          let wrapper_hs :: String
wrapper_hs = String
cacheDir String -> String -> String
</> String
wrapper_name String -> String -> String
<.> String
"hs"
          String -> LoggingFunction
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 -> LoggingFunction -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggingFunction
putStr
      else String -> LoggingFunction
writeFile String
wrapper_fp String
wrapperContents
    LoggingFunction
setMode String
wrapper_fp
    String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
wrapper_fp
  where
    setMode :: LoggingFunction
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
work_dir = do
  String
abs_work_dir <- String -> IO String
makeAbsolute String
work_dir
  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)

cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
cabalAction :: String
-> Maybe String
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
cabalAction String
work_dir Maybe String
mc LoggingFunction
l String
fp = do
    String
wrapper_fp <- GhcProc -> String -> IO String
withCabalWrapperTool (String
"ghc", []) String
work_dir
    String
buildDir <- String -> IO String
cabalBuildDir String
work_dir
    let cab_args :: [String]
cab_args = [String
"--builddir="String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
buildDir,String
"v2-repl", String
"--with-compiler", String
wrapper_fp, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
fixTargetPath String
fp) Maybe String
mc]
    (ExitCode
ex, [String]
output, [String]
stde, [(String
_,Maybe [String]
mb_args)]) <-
      [String]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LoggingFunction
l String
work_dir (String -> [String] -> CreateProcess
proc String
"cabal" [String]
cab_args)
    let args :: [String]
args = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
mb_args
    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 -> IO [String]
cabalCradleDependencies String
work_dir String
work_dir
          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
ex
                    [String
"Failed to parse result of calling cabal"
                     , [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])
        Just (String
componentDir, [String]
final_args) -> do
          [String]
deps <- String -> String -> IO [String]
cabalCradleDependencies String
work_dir String
componentDir
          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
work_dir 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
-> (LoggingFunction
    -> String -> IO (CradleLoadResult ComponentOptions))
-> ([String] -> IO (CradleLoadResult String))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Stack
        , runCradle :: LoggingFunction -> String -> IO (CradleLoadResult ComponentOptions)
runCradle = String
-> Maybe String
-> StackYaml
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
stackAction String
wdir Maybe String
mc StackYaml
syaml
        , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> 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
            CradleLoadResult String
stackSetup <- String
-> String -> [String] -> String -> IO (CradleLoadResult 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
""
            CradleLoadResult String
stackSetup CradleLoadResult String
-> (String -> IO (CradleLoadResult String))
-> IO (CradleLoadResult String)
forall a b.
CradleLoadResult a
-> (a -> IO (CradleLoadResult b)) -> IO (CradleLoadResult b)
`bindIO` \String
_ ->
              String
-> String -> [String] -> String -> IO (CradleLoadResult 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 -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
stackAction :: String
-> Maybe String
-> StackYaml
-> LoggingFunction
-> String
-> IO (CradleLoadResult ComponentOptions)
stackAction String
work_dir Maybe String
mc StackYaml
syaml LoggingFunction
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
withCabalWrapperTool GhcProc
ghcProcArgs String
work_dir
  (ExitCode
ex1, [String]
_stdo, [String]
stde, [(String
_, Maybe [String]
mb_args)]) <-
    [String]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LoggingFunction
l String
work_dir (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]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String
hie_bios_output] LoggingFunction
l String
work_dir (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]
mb_args
  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
work_dir String
work_dir 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
work_dir 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
isStack
  where
    isStack :: String -> Bool
isStack String
name = String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"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 work_dir fp = do
  wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand
  setFileMode wrapper_fp accessModes
  let rel_path = makeRelative work_dir fp
  (ex, args, stde) <-
      readProcessWithOutputFile work_dir wrapper_fp [rel_path] []
  let args'  = filter (/= '\'') args
  let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')
  deps <- rulesHaskellCradleDependencies work_dir
  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 work_dir _fp = do
  (ex, args, stde) <-
      readProcessWithOutputFile work_dir "ob" ["ide-args"] []

  o_deps <- obeliskCradleDependencies work_dir
  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
  [(String, String)]
e <- IO [(String, String)]
getEnvironment
  [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ HashMap String String -> [(String, String)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap String String -> [(String, String)])
-> HashMap String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ 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)
-> HashMap String String -> HashMap String String
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> HashMap String String
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(String, String)]
e

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
  -> LoggingFunction -- ^ Output of the process is streamed into this function.
  -> 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]
-> LoggingFunction
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
readProcessWithOutputs [String]
outputNames LoggingFunction
l String
work_dir 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
work_dir
                    }

    -- 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..| LoggingFunction -> ConduitT String String IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ConduitT a a m ()
C.iterM LoggingFunction
l 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
            LoggingFunction
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
            LoggingFunction
removeFileIfExists String
file
            (String, String) -> IO a
action (String
name, String
file)

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists :: LoggingFunction
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 (LoggingFunction
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
readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd :: String
-> String -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd String
dir String
cmd [String]
args String
stdi = do
  [(String, String)]
cleanEnv <- 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 }
  Maybe (ExitCode, String, String)
mResult <- 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
createProc String
stdi
  case Maybe (ExitCode, String, String)
mResult of
    Just (ExitCode
ExitSuccess, String
stdo, String
_) -> CradleLoadResult String -> IO (CradleLoadResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult String -> IO (CradleLoadResult String))
-> CradleLoadResult String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ String -> CradleLoadResult String
forall r. r -> CradleLoadResult r
CradleSuccess String
stdo
    Just (ExitCode
exitCode, String
stdo, String
stde) -> CradleLoadResult String -> IO (CradleLoadResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult String -> IO (CradleLoadResult String))
-> CradleLoadResult String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ CradleError -> CradleLoadResult String
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError -> CradleLoadResult String)
-> CradleError -> CradleLoadResult String
forall a b. (a -> b) -> a -> b
$
      [String] -> ExitCode -> [String] -> CradleError
CradleError [] ExitCode
exitCode [String
"Error when calling " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
args, String
stdo, String
stde]
    Maybe (ExitCode, String, String)
Nothing -> CradleLoadResult String -> IO (CradleLoadResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult String -> IO (CradleLoadResult String))
-> CradleLoadResult String -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ CradleError -> CradleLoadResult String
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError -> CradleLoadResult String)
-> CradleError -> CradleLoadResult String
forall a b. (a -> b) -> a -> b
$
      [String] -> ExitCode -> [String] -> CradleError
CradleError [] ExitCode
ExitSuccess [String
"Couldn't execute " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
args]