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

import Control.Exception (handleJust)
import qualified Data.Yaml as Yaml
import Data.Void
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 System.Directory hiding (findFile)
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)

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

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

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

loadCustomCradle :: Yaml.FromJSON b => (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCustomCradle :: (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCustomCradle = CradleOpts -> (b -> Cradle a) -> FilePath -> IO (Cradle a)
forall b a.
FromJSON b =>
CradleOpts -> (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCradleWithOpts CradleOpts
Types.defaultCradleOpts

-- | Given root\/foo\/bar.hs, load an implicit cradle
loadImplicitCradle :: Show a => FilePath -> IO (Cradle a)
loadImplicitCradle :: FilePath -> IO (Cradle a)
loadImplicitCradle wfile :: FilePath
wfile = do
  let wdir :: FilePath
wdir = FilePath -> FilePath
takeDirectory FilePath
wfile
  Maybe (CradleConfig Void, FilePath)
cfg <- MaybeT IO (CradleConfig Void, FilePath)
-> IO (Maybe (CradleConfig Void, FilePath))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (FilePath -> MaybeT IO (CradleConfig Void, FilePath)
forall a. FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig FilePath
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, FilePath)
cfg of
    Just bc :: (CradleConfig Void, FilePath)
bc -> (Void -> Cradle a) -> (CradleConfig Void, FilePath) -> Cradle a
forall b a.
(b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
getCradle Void -> Cradle a
forall a. Void -> a
absurd (CradleConfig Void, FilePath)
bc
    Nothing -> FilePath -> Cradle a
forall a. FilePath -> Cradle a
defaultCradle FilePath
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) => CradleOpts -> (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCradleWithOpts :: CradleOpts -> (b -> Cradle a) -> FilePath -> IO (Cradle a)
loadCradleWithOpts _copts :: CradleOpts
_copts buildCustomCradle :: b -> Cradle a
buildCustomCradle wfile :: FilePath
wfile = do
    CradleConfig b
cradleConfig <- FilePath -> IO (CradleConfig b)
forall b. FromJSON b => FilePath -> IO (CradleConfig b)
readCradleConfig FilePath
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, FilePath) -> Cradle a
forall b a.
(b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
cradleConfig, FilePath -> FilePath
takeDirectory FilePath
wfile)

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

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


implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig fp :: FilePath
fp = do
  (crdType :: CradleType a
crdType, wdir :: FilePath
wdir) <- FilePath -> MaybeT IO (CradleType a, FilePath)
forall a. FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' FilePath
fp
  (CradleConfig a, FilePath) -> MaybeT IO (CradleConfig a, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> CradleType a -> CradleConfig a
forall a. [FilePath] -> CradleType a -> CradleConfig a
CradleConfig [] CradleType a
crdType, FilePath
wdir)

implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' :: FilePath -> MaybeT IO (CradleType a, FilePath)
implicitConfig' fp :: FilePath
fp = (\wdir :: FilePath
wdir ->
         (Callable -> Maybe Callable -> Maybe FilePath -> CradleType a
forall a.
Callable -> Maybe Callable -> Maybe FilePath -> CradleType a
Bios (FilePath -> Callable
Program (FilePath -> Callable) -> FilePath -> Callable
forall a b. (a -> b) -> a -> b
$ FilePath
wdir FilePath -> FilePath -> FilePath
</> ".hie-bios") Maybe Callable
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing, FilePath
wdir)) (FilePath -> (CradleType a, FilePath))
-> MaybeT IO FilePath -> MaybeT IO (CradleType a, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> MaybeT IO FilePath
biosWorkDir FilePath
fp
  --   <|> (Obelisk,) <$> obeliskWorkDir fp
  --   <|> (Bazel,) <$> rulesHaskellWorkDir fp
     MaybeT IO (CradleType a, FilePath)
-> MaybeT IO (CradleType a, FilePath)
-> MaybeT IO (CradleType a, FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MaybeT IO FilePath
stackExecutable MaybeT IO FilePath
-> MaybeT IO (CradleType a, FilePath)
-> MaybeT IO (CradleType a, FilePath)
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 FilePath -> Maybe FilePath -> StackType
StackType Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing,) (FilePath -> (CradleType a, FilePath))
-> MaybeT IO FilePath -> MaybeT IO (CradleType a, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> MaybeT IO FilePath
stackWorkDir FilePath
fp)
     MaybeT IO (CradleType a, FilePath)
-> MaybeT IO (CradleType a, FilePath)
-> MaybeT IO (CradleType a, FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((CabalType -> CradleType a
forall a. CabalType -> CradleType a
Cabal (CabalType -> CradleType a) -> CabalType -> CradleType a
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> CabalType
CabalType Maybe FilePath
forall a. Maybe a
Nothing,) (FilePath -> (CradleType a, FilePath))
-> MaybeT IO FilePath -> MaybeT IO (CradleType a, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> MaybeT IO FilePath
cabalWorkDir FilePath
fp)


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

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

readCradleConfig :: Yaml.FromJSON b => FilePath -> IO (CradleConfig b)
readCradleConfig :: FilePath -> IO (CradleConfig b)
readCradleConfig yamlHie :: FilePath
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
$ FilePath -> IO (Config b)
forall a. FromJSON a => FilePath -> IO (Config a)
readConfig FilePath
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 :: FilePath
configFileName = "hie.yaml"

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

isCabalCradle :: Cradle a -> Bool
isCabalCradle :: Cradle a -> Bool
isCabalCradle crdl :: 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.Cabal -> Bool
True
  _ -> Bool
False

isStackCradle :: Cradle a -> Bool
isStackCradle :: Cradle a -> Bool
isStackCradle crdl :: 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.Stack -> Bool
True
  _ -> Bool
False

isDirectCradle :: Cradle a -> Bool
isDirectCradle :: Cradle a -> Bool
isDirectCradle crdl :: 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.Direct -> Bool
True
  _ -> Bool
False

isBiosCradle :: Cradle a -> Bool
isBiosCradle :: Cradle a -> Bool
isBiosCradle crdl :: 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.Bios -> Bool
True
  _ -> Bool
False

isMultiCradle :: Cradle a -> Bool
isMultiCradle :: Cradle a -> Bool
isMultiCradle crdl :: 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.Multi -> Bool
True
  _ -> Bool
False

isNoneCradle :: Cradle a -> Bool
isNoneCradle :: Cradle a -> Bool
isNoneCradle crdl :: 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.None -> Bool
True
  _ -> Bool
False

isDefaultCradle :: Cradle a -> Bool
isDefaultCradle :: Cradle a -> Bool
isDefaultCradle crdl :: 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.Default -> Bool
True
  _ -> Bool
False

isOtherCradle :: Cradle a -> Bool
isOtherCradle :: Cradle a -> Bool
isOtherCradle crdl :: 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 _ -> Bool
True
  _ -> Bool
False

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

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

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

noneCradle :: FilePath -> Cradle a
noneCradle :: FilePath -> Cradle a
noneCradle cur_dir :: FilePath
cur_dir =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir = FilePath
cur_dir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.None
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle = \_ _ -> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult ComponentOptions
forall r. CradleLoadResult r
CradleNone
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = \_   -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult FilePath
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)
-> FilePath -> [(FilePath, CradleConfig b)] -> Cradle a
multiCradle buildCustomCradle :: b -> Cradle a
buildCustomCradle cur_dir :: FilePath
cur_dir cs :: [(FilePath, CradleConfig b)]
cs =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir  = FilePath
cur_dir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
multiActionName
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle  = \l :: LoggingFunction
l fp :: FilePath
fp -> FilePath -> IO FilePath
makeAbsolute FilePath
fp IO FilePath
-> (FilePath -> IO (CradleLoadResult ComponentOptions))
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> Cradle a)
-> FilePath
-> [(FilePath, CradleConfig b)]
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
forall b a.
(b -> Cradle a)
-> FilePath
-> [(FilePath, CradleConfig b)]
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
multiAction b -> Cradle a
buildCustomCradle FilePath
cur_dir [(FilePath, CradleConfig b)]
cs LoggingFunction
l
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = \args :: [FilePath]
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
$ ((FilePath, CradleConfig b) -> CradleConfig b)
-> [(FilePath, CradleConfig b)] -> [CradleConfig b]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, CradleConfig b) -> CradleConfig b
forall a b. (a, b) -> b
snd [(FilePath, CradleConfig b)]
cs of
              [] -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult FilePath
forall r. CradleLoadResult r
CradleNone
              (cfg :: CradleConfig b
cfg:_) -> (CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath))
-> [FilePath] -> CradleAction a -> IO (CradleLoadResult FilePath)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
forall a.
CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd [FilePath]
args (CradleAction a -> IO (CradleLoadResult FilePath))
-> CradleAction a -> IO (CradleLoadResult FilePath)
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, FilePath) -> Cradle a
forall b a.
(b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
cfg, FilePath
cur_dir)
        }
    }
  where
    cfgs :: [CradleConfig b]
cfgs = ((FilePath, CradleConfig b) -> CradleConfig b)
-> [(FilePath, CradleConfig b)] -> [CradleConfig b]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, CradleConfig b) -> CradleConfig b
forall a b. (a, b) -> b
snd [(FilePath, CradleConfig b)]
cs

    multiActionName :: ActionName a
multiActionName
      | (CradleConfig b -> Bool) -> [CradleConfig b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\c :: 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 (\c :: 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 cfg :: 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
      _            -> Bool
False

    isCabalCradleConfig :: CradleConfig a -> Bool
isCabalCradleConfig cfg :: 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
      _            -> Bool
False

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

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

  where
    err_msg :: [FilePath]
err_msg = ["Multi Cradle: No prefixes matched"
              , "pwd: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cur_dir
              , "filepath: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cur_fp
              , "prefixes:"
              ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [(FilePath, CradleType b) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath
pf, CradleConfig b -> CradleType b
forall a. CradleConfig a -> CradleType a
cradleType CradleConfig b
cc) | (pf :: FilePath
pf, cc :: CradleConfig b
cc) <- [(FilePath, 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 [(FilePath, CradleConfig b)]
canonicalizeCradles =
      ((FilePath, CradleConfig b) -> Down FilePath)
-> [(FilePath, CradleConfig b)] -> [(FilePath, CradleConfig b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FilePath -> Down FilePath
forall a. a -> Down a
Down (FilePath -> Down FilePath)
-> ((FilePath, CradleConfig b) -> FilePath)
-> (FilePath, CradleConfig b)
-> Down FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, CradleConfig b) -> FilePath
forall a b. (a, b) -> a
fst)
        ([(FilePath, CradleConfig b)] -> [(FilePath, CradleConfig b)])
-> IO [(FilePath, CradleConfig b)]
-> IO [(FilePath, CradleConfig b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, CradleConfig b) -> IO (FilePath, CradleConfig b))
-> [(FilePath, CradleConfig b)] -> IO [(FilePath, CradleConfig b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(p :: FilePath
p, c :: CradleConfig b
c) -> (,CradleConfig b
c) (FilePath -> (FilePath, CradleConfig b))
-> IO FilePath -> IO (FilePath, CradleConfig b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO FilePath
makeAbsolute (FilePath
cur_dir FilePath -> FilePath -> FilePath
</> FilePath
p))) [(FilePath, CradleConfig b)]
cs

    selectCradle :: [(FilePath, 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 ([FilePath] -> ExitCode -> [FilePath] -> CradleError
CradleError [] ExitCode
ExitSuccess [FilePath]
err_msg))
    selectCradle ((p :: FilePath
p, c :: CradleConfig b
c): css :: [(FilePath, CradleConfig b)]
css) =
        if FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
cur_fp
          then CradleAction a
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
runCradle
                  (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg ((b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
forall b a.
(b -> Cradle a) -> (CradleConfig b, FilePath) -> Cradle a
getCradle b -> Cradle a
buildCustomCradle (CradleConfig b
c, FilePath
cur_dir)))
                  LoggingFunction
l
                  FilePath
cur_fp
          else [(FilePath, CradleConfig b)]
-> IO (CradleLoadResult ComponentOptions)
selectCradle [(FilePath, CradleConfig b)]
css


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

directCradle :: FilePath -> [String] -> Cradle a
directCradle :: FilePath -> [FilePath] -> Cradle a
directCradle wdir :: FilePath
wdir args :: [FilePath]
args =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir = FilePath
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Direct
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle = \_ _ ->
            CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ([FilePath] -> FilePath -> [FilePath] -> ComponentOptions
ComponentOptions [FilePath]
args FilePath
wdir []))
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = FilePath -> [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmdOnPath FilePath
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 :: FilePath
-> Callable -> Maybe Callable -> Maybe FilePath -> Cradle a
biosCradle wdir :: FilePath
wdir biosCall :: Callable
biosCall biosDepsCall :: Maybe Callable
biosDepsCall mbGhc :: Maybe FilePath
mbGhc =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir    = FilePath
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Bios
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle = FilePath
-> Callable
-> Maybe Callable
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
biosAction FilePath
wdir Callable
biosCall Maybe Callable
biosDepsCall
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = \args :: [FilePath]
args -> FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd FilePath
wdir (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "ghc" Maybe FilePath
mbGhc) [FilePath]
args ""
        }
    }

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

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

biosAction :: FilePath
           -> Callable
           -> Maybe Callable
           -> LoggingFunction
           -> FilePath
           -> IO (CradleLoadResult ComponentOptions)
biosAction :: FilePath
-> Callable
-> Maybe Callable
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
biosAction wdir :: FilePath
wdir bios :: Callable
bios bios_deps :: Maybe Callable
bios_deps l :: LoggingFunction
l fp :: FilePath
fp = do
  CreateProcess
bios' <- Callable -> Maybe FilePath -> IO CreateProcess
callableToProcess Callable
bios (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp)
  (ex :: ExitCode
ex, _stdo :: [FilePath]
_stdo, std :: [FilePath]
std, res :: [FilePath]
res) <- LoggingFunction
-> FilePath
-> CreateProcess
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
readProcessWithOutputFile LoggingFunction
l FilePath
wdir CreateProcess
bios'
  [FilePath]
deps <- LoggingFunction
-> FilePath -> Maybe Callable -> FilePath -> IO [FilePath]
biosDepsAction LoggingFunction
l FilePath
wdir Maybe Callable
bios_deps FilePath
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, [FilePath], FilePath, [FilePath])
-> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [FilePath]
std, FilePath
wdir, [FilePath]
res) [FilePath]
deps

callableToProcess :: Callable -> Maybe String -> IO CreateProcess
callableToProcess :: Callable -> Maybe FilePath -> IO CreateProcess
callableToProcess (Command shellCommand :: FilePath
shellCommand) file :: Maybe FilePath
file = do
  [(FilePath, FilePath)]
old_env <- IO [(FilePath, FilePath)]
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
$ (FilePath -> CreateProcess
shell FilePath
shellCommand) { env :: Maybe [(FilePath, FilePath)]
env = ((FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
old_env) ((FilePath, FilePath) -> [(FilePath, FilePath)])
-> (FilePath -> (FilePath, FilePath))
-> FilePath
-> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,) FilePath
hieBiosArg (FilePath -> [(FilePath, FilePath)])
-> Maybe FilePath -> Maybe [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
file }
    where
      hieBiosArg :: FilePath
hieBiosArg = "HIE_BIOS_ARG"
callableToProcess (Program path :: FilePath
path) file :: Maybe FilePath
file = do
  FilePath
canon_path <- FilePath -> IO FilePath
canonicalizePath FilePath
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
$ FilePath -> [FilePath] -> CreateProcess
proc FilePath
canon_path (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
file)

------------------------------------------------------------------------
-- |Cabal Cradle
-- Works for new-build by invoking `v2-repl`.
cabalCradle :: FilePath -> Maybe String -> Cradle a
cabalCradle :: FilePath -> Maybe FilePath -> Cradle a
cabalCradle wdir :: FilePath
wdir mc :: Maybe FilePath
mc =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir    = FilePath
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Cabal
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle = FilePath
-> Maybe FilePath
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
cabalAction FilePath
wdir Maybe FilePath
mc
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = \args :: [FilePath]
args -> do
            -- 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)
            -- (It's ok to pass 'dist-newstyle' here, as it can only be changed
            -- with the --builddir flag and not cabal.project, which we aren't
            -- using in our call to v2-exec)
            Bool -> LoggingFunction
createDirectoryIfMissing Bool
True (FilePath
wdir FilePath -> FilePath -> FilePath
</> "dist-newstyle" FilePath -> FilePath -> FilePath
</> "tmp")
            -- Need to pass -v0 otherwise we get "resolving dependencies..."
            FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd
              FilePath
wdir "cabal" (["v2-exec", "ghc", "-v0", "--"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
args) ""
        }
    }

-- | @'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 :: FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies rootDir :: FilePath
rootDir componentDir :: FilePath
componentDir = do
    let relFp :: FilePath
relFp = FilePath -> FilePath -> FilePath
makeRelative FilePath
rootDir FilePath
componentDir
    [FilePath]
cabalFiles' <- FilePath -> IO [FilePath]
findCabalFiles FilePath
componentDir
    let cabalFiles :: [FilePath]
cabalFiles = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
relFp FilePath -> FilePath -> FilePath
</>) [FilePath]
cabalFiles'
    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
cabalFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["cabal.project", "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 :: FilePath -> IO [FilePath]
findCabalFiles wdir :: FilePath
wdir = do
  [FilePath]
dirContent <- FilePath -> IO [FilePath]
listDirectory FilePath
wdir
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".cabal") (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) [FilePath]
dirContent


processCabalWrapperArgs :: [String] -> Maybe (FilePath, [String])
processCabalWrapperArgs :: [FilePath] -> Maybe (FilePath, [FilePath])
processCabalWrapperArgs args :: [FilePath]
args =
    case [FilePath]
args of
        (dir :: FilePath
dir: ghc_args :: [FilePath]
ghc_args) ->
            let final_args :: [FilePath]
final_args =
                    [FilePath] -> [FilePath]
removeVerbosityOpts
                    ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
removeRTS
                    ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
removeInteractive
                    ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
ghc_args
            in (FilePath, [FilePath]) -> Maybe (FilePath, [FilePath])
forall a. a -> Maybe a
Just (FilePath
dir, [FilePath]
final_args)
        _ -> Maybe (FilePath, [FilePath])
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 -> (FilePath -> IO a) -> IO a
withCabalWrapperTool :: (FilePath, [FilePath]) -> FilePath -> (FilePath -> IO a) -> IO a
withCabalWrapperTool (mbGhc :: FilePath
mbGhc, ghcArgs :: [FilePath]
ghcArgs) wdir :: FilePath
wdir k :: FilePath -> IO a
k = do
  if Bool
isWindows
    then do
      FilePath
cacheDir <- FilePath -> IO FilePath
getCacheDir ""
      let srcHash :: FilePath
srcHash = Fingerprint -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> Fingerprint
fingerprintString FilePath
cabalWrapperHs)
      let wrapper_name :: FilePath
wrapper_name = "wrapper-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
srcHash
      let wrapper_fp :: FilePath
wrapper_fp = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
wrapper_name FilePath -> FilePath -> FilePath
<.> "exe"
      Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
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
$ FilePath -> LoggingFunction -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory "hie-bios" (LoggingFunction -> IO ()) -> LoggingFunction -> IO ()
forall a b. (a -> b) -> a -> b
$ \ tmpDir :: FilePath
tmpDir -> do
          Bool -> LoggingFunction
createDirectoryIfMissing Bool
True FilePath
cacheDir
          let wrapper_hs :: FilePath
wrapper_hs = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
wrapper_name FilePath -> FilePath -> FilePath
<.> "hs"
          FilePath -> LoggingFunction
writeFile FilePath
wrapper_hs FilePath
cabalWrapperHs
          let ghc :: CreateProcess
ghc = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
mbGhc ([FilePath] -> CreateProcess) -> [FilePath] -> CreateProcess
forall a b. (a -> b) -> a -> b
$
                      [FilePath]
ghcArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["-rtsopts=ignore", "-outputdir", FilePath
tmpDir, "-o", FilePath
wrapper_fp, FilePath
wrapper_hs])
                      { cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
wdir }
          CreateProcess -> FilePath -> IO FilePath
readCreateProcess CreateProcess
ghc "" IO FilePath -> LoggingFunction -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LoggingFunction
putStr
      LoggingFunction
setMode FilePath
wrapper_fp
      FilePath -> IO a
k FilePath
wrapper_fp
    else FilePath -> (FilePath -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile "bios-wrapper"
            (\loc :: FilePath
loc h :: Handle
h -> do
                        Handle -> LoggingFunction
hPutStr Handle
h FilePath
cabalWrapper
                        Handle -> IO ()
hClose Handle
h
                        LoggingFunction
setMode FilePath
loc
                        FilePath -> IO a
k FilePath
loc)

  where
    setMode :: LoggingFunction
setMode wrapper_fp :: FilePath
wrapper_fp = FilePath -> FileMode -> IO ()
setFileMode FilePath
wrapper_fp FileMode
accessModes


cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
cabalAction :: FilePath
-> Maybe FilePath
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
cabalAction work_dir :: FilePath
work_dir mc :: Maybe FilePath
mc l :: LoggingFunction
l fp :: FilePath
fp = do
  (FilePath, [FilePath])
-> FilePath
-> (FilePath -> IO (CradleLoadResult ComponentOptions))
-> IO (CradleLoadResult ComponentOptions)
forall a.
(FilePath, [FilePath]) -> FilePath -> (FilePath -> IO a) -> IO a
withCabalWrapperTool ("ghc", []) FilePath
work_dir ((FilePath -> IO (CradleLoadResult ComponentOptions))
 -> IO (CradleLoadResult ComponentOptions))
-> (FilePath -> IO (CradleLoadResult ComponentOptions))
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ \wrapper_fp :: FilePath
wrapper_fp -> do
    let cab_args :: [FilePath]
cab_args = ["v2-repl", "--with-compiler", FilePath
wrapper_fp, FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
fixTargetPath FilePath
fp) Maybe FilePath
mc]
    (ex :: ExitCode
ex, output :: [FilePath]
output, stde :: [FilePath]
stde, args :: [FilePath]
args) <-
      LoggingFunction
-> FilePath
-> CreateProcess
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
readProcessWithOutputFile LoggingFunction
l FilePath
work_dir (FilePath -> [FilePath] -> CreateProcess
proc "cabal" [FilePath]
cab_args)
    case [FilePath] -> Maybe (FilePath, [FilePath])
processCabalWrapperArgs [FilePath]
args of
        Nothing -> do
          -- Best effort. Assume the working directory is the
          -- the root of the component, so we are right in trivial cases at least.
          [FilePath]
deps <- FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies FilePath
work_dir FilePath
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 ([FilePath] -> ExitCode -> [FilePath] -> CradleError
CradleError [FilePath]
deps ExitCode
ex
                    ["Failed to parse result of calling cabal"
                     , [FilePath] -> FilePath
unlines [FilePath]
output
                     , [FilePath] -> FilePath
unlines [FilePath]
stde
                     , [FilePath] -> FilePath
unlines [FilePath]
args])
        Just (componentDir :: FilePath
componentDir, final_args :: [FilePath]
final_args) -> do
          [FilePath]
deps <- FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies FilePath
work_dir FilePath
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, [FilePath], FilePath, [FilePath])
-> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [FilePath]
stde, FilePath
componentDir, [FilePath]
final_args) [FilePath]
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 :: FilePath -> FilePath
fixTargetPath x :: FilePath
x
      | Bool
isWindows Bool -> Bool -> Bool
&& FilePath -> Bool
hasDrive FilePath
x = FilePath -> FilePath -> FilePath
makeRelative FilePath
work_dir FilePath
x
      | Bool
otherwise = FilePath
x

removeInteractive :: [String] -> [String]
removeInteractive :: [FilePath] -> [FilePath]
removeInteractive = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "--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 :: [FilePath] -> [FilePath]
removeRTS = InRTS -> [FilePath] -> [FilePath]
go InRTS
OutsideRTS
  where
    go :: InRTS -> [String] -> [String]
    go :: InRTS -> [FilePath] -> [FilePath]
go _ [] = []
    go OutsideRTS (y :: FilePath
y:ys :: [FilePath]
ys)
      | "+RTS" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
y = InRTS -> [FilePath] -> [FilePath]
go (if "-RTS" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
y then InRTS
OutsideRTS else InRTS
InsideRTS) [FilePath]
ys
      | Bool
otherwise = FilePath
y FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: InRTS -> [FilePath] -> [FilePath]
go InRTS
OutsideRTS [FilePath]
ys
    go InsideRTS (y :: FilePath
y:ys :: [FilePath]
ys) = InRTS -> [FilePath] -> [FilePath]
go (if "-RTS" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
y then InRTS
OutsideRTS else InRTS
InsideRTS) [FilePath]
ys


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


cabalWorkDir :: FilePath -> MaybeT IO FilePath
cabalWorkDir :: FilePath -> MaybeT IO FilePath
cabalWorkDir wdir :: FilePath
wdir =
      (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "cabal.project") FilePath
wdir
  MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards (\fp :: FilePath
fp -> FilePath -> FilePath
takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".cabal") FilePath
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 :: FilePath -> Maybe FilePath -> StackYaml
stackYamlFromMaybe _wdir :: FilePath
_wdir Nothing = StackYaml
NoExplicitYaml
stackYamlFromMaybe wdir :: FilePath
wdir (Just fp :: FilePath
fp) = FilePath -> StackYaml
ExplicitYaml (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
fp)

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

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

-- | Stack Cradle
-- Works for by invoking `stack repl` with a wrapper script
stackCradle :: FilePath -> Maybe String -> StackYaml -> Cradle a
stackCradle :: FilePath -> Maybe FilePath -> StackYaml -> Cradle a
stackCradle wdir :: FilePath
wdir mc :: Maybe FilePath
mc syaml :: StackYaml
syaml =
  Cradle :: forall a. FilePath -> CradleAction a -> Cradle a
Cradle
    { cradleRootDir :: FilePath
cradleRootDir    = FilePath
wdir
    , cradleOptsProg :: CradleAction a
cradleOptsProg   = CradleAction :: forall a.
ActionName a
-> (LoggingFunction
    -> FilePath -> IO (CradleLoadResult ComponentOptions))
-> ([FilePath] -> IO (CradleLoadResult FilePath))
-> CradleAction a
CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall a. ActionName a
Types.Stack
        , runCradle :: LoggingFunction
-> FilePath -> IO (CradleLoadResult ComponentOptions)
runCradle = FilePath
-> Maybe FilePath
-> StackYaml
-> LoggingFunction
-> FilePath
-> IO (CradleLoadResult ComponentOptions)
stackAction FilePath
wdir Maybe FilePath
mc StackYaml
syaml
        , runGhcCmd :: [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd = \args :: [FilePath]
args ->
            FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd FilePath
wdir "stack"
              (StackYaml -> [FilePath]
stackYamlProcessArgs StackYaml
syaml [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> ["exec", "--silent", "ghc", "--"] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
args)
              ""
        }
    }

-- | @'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 :: FilePath -> FilePath -> StackYaml -> IO [FilePath]
stackCradleDependencies wdir :: FilePath
wdir componentDir :: FilePath
componentDir syaml :: StackYaml
syaml = do
  let relFp :: FilePath
relFp = FilePath -> FilePath -> FilePath
makeRelative FilePath
wdir FilePath
componentDir
  [FilePath]
cabalFiles' <- FilePath -> IO [FilePath]
findCabalFiles FilePath
componentDir
  let cabalFiles :: [FilePath]
cabalFiles = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
relFp FilePath -> FilePath -> FilePath
</>) [FilePath]
cabalFiles'
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    [FilePath]
cabalFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
relFp FilePath -> FilePath -> FilePath
</> "package.yaml", StackYaml -> FilePath
stackYamlLocationOrDefault StackYaml
syaml]

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

        Just (componentDir :: FilePath
componentDir, ghc_args :: [FilePath]
ghc_args) -> do
          [FilePath]
deps <- FilePath -> FilePath -> StackYaml -> IO [FilePath]
stackCradleDependencies FilePath
work_dir FilePath
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, [FilePath], FilePath, [FilePath])
-> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult
                    ( [ExitCode] -> ExitCode
combineExitCodes [ExitCode
ex1, ExitCode
ex2]
                    , [FilePath]
stde [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
stdr, FilePath
componentDir
                    , [FilePath]
ghc_args [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_ghc_args
                    )
                    [FilePath]
deps

stackProcess :: StackYaml -> [String] -> CreateProcess
stackProcess :: StackYaml -> [FilePath] -> CreateProcess
stackProcess syaml :: StackYaml
syaml args :: [FilePath]
args = FilePath -> [FilePath] -> CreateProcess
proc "stack" ([FilePath] -> CreateProcess) -> [FilePath] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ StackYaml -> [FilePath]
stackYamlProcessArgs StackYaml
syaml [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
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 ExitSuccess b :: ExitCode
b = ExitCode
b
    go a :: ExitCode
a _ = ExitCode
a

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

stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir :: FilePath -> MaybeT IO FilePath
stackWorkDir = (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards FilePath -> Bool
isStack
  where
    isStack :: FilePath -> Bool
isStack name :: FilePath
name = FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "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 :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath
findFileUpwards p :: FilePath -> Bool
p dir :: FilePath
dir = do
  [FilePath]
cnts <-
    IO [FilePath] -> MaybeT IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO [FilePath] -> MaybeT IO [FilePath])
-> IO [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe [FilePath])
-> ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
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 [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [] else Maybe [FilePath]
forall a. Maybe a
Nothing)
        [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ((FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile FilePath -> Bool
p FilePath
dir)

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

-- | Sees if any file in the directory matches the predicate
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findFile p :: FilePath -> Bool
p dir :: FilePath
dir = do
  Bool
b <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
  if Bool
b then IO [FilePath]
getFiles IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesPredFileExist else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    getFiles :: IO [FilePath]
getFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
p ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
    doesPredFileExist :: FilePath -> IO Bool
doesPredFileExist file :: FilePath
file = FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
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 [(FilePath, FilePath)]
getCleanEnvironment = do
  [(FilePath, FilePath)]
e <- IO [(FilePath, FilePath)]
getEnvironment
  [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, FilePath)] -> IO [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ HashMap FilePath FilePath -> [(FilePath, FilePath)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap FilePath FilePath -> [(FilePath, FilePath)])
-> HashMap FilePath FilePath -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> HashMap FilePath FilePath -> HashMap FilePath FilePath
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete "GHC_PACKAGE_PATH" (HashMap FilePath FilePath -> HashMap FilePath FilePath)
-> HashMap FilePath FilePath -> HashMap FilePath FilePath
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> HashMap FilePath FilePath
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(FilePath, FilePath)]
e

-- | Call a given process.
-- * A special file is created for the process to write to, the process can discover the name of
-- the file by reading the @HIE_BIOS_OUTPUT@ environment variable. The contents of this file is
-- returned by the function.
-- * 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.
readProcessWithOutputFile
  :: 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], [String])
readProcessWithOutputFile :: LoggingFunction
-> FilePath
-> CreateProcess
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
readProcessWithOutputFile l :: LoggingFunction
l work_dir :: FilePath
work_dir cp :: CreateProcess
cp = do
  [(FilePath, FilePath)]
old_env <- IO [(FilePath, FilePath)]
getCleanEnvironment

  [(FilePath, FilePath)]
-> (FilePath -> IO (ExitCode, [FilePath], [FilePath], [FilePath]))
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
forall a. [(FilePath, FilePath)] -> (FilePath -> IO a) -> IO a
withHieBiosOutput [(FilePath, FilePath)]
old_env ((FilePath -> IO (ExitCode, [FilePath], [FilePath], [FilePath]))
 -> IO (ExitCode, [FilePath], [FilePath], [FilePath]))
-> (FilePath -> IO (ExitCode, [FilePath], [FilePath], [FilePath]))
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
forall a b. (a -> b) -> a -> b
$ \output_file :: FilePath
output_file -> do
    -- Pipe stdout directly into the logger
    let process :: CreateProcess
process = CreateProcess
cp { env :: Maybe [(FilePath, FilePath)]
env = [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just
                              ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (FilePath
hieBiosOutput, FilePath
output_file)
                              (FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: ([(FilePath, FilePath)]
-> Maybe [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> Maybe a -> a
fromMaybe [(FilePath, FilePath)]
old_env (CreateProcess -> Maybe [(FilePath, FilePath)]
env CreateProcess
cp)),
                       cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
work_dir
                      }

    -- Windows line endings are not converted so you have to filter out `'r` characters
    let  loggingConduit :: ConduitM ByteString c IO [FilePath]
loggingConduit = (ConduitT ByteString Text IO ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
C.decodeUtf8  ConduitT ByteString Text IO ()
-> ConduitM Text c IO [FilePath]
-> ConduitM ByteString c IO [FilePath]
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 [FilePath] -> ConduitM Text c IO [FilePath]
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
/= '\r')  ConduitT Text Text IO ()
-> ConduitM Text c IO [FilePath] -> ConduitM Text c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| (Text -> FilePath) -> ConduitT Text FilePath IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
C.map Text -> FilePath
T.unpack ConduitT Text FilePath IO ()
-> ConduitM FilePath c IO [FilePath]
-> ConduitM Text c IO [FilePath]
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 FilePath FilePath IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> ConduitT a a m ()
C.iterM LoggingFunction
l ConduitT FilePath FilePath IO ()
-> ConduitM FilePath c IO [FilePath]
-> ConduitM FilePath c IO [FilePath]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| ConduitM FilePath c IO [FilePath]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
C.sinkList)
    (ex :: ExitCode
ex, stdo :: [FilePath]
stdo, stde :: [FilePath]
stde) <- CreateProcess
-> ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO [FilePath]
-> ConduitT ByteString Void IO [FilePath]
-> IO (ExitCode, [FilePath], [FilePath])
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 [FilePath]
forall c. ConduitM ByteString c IO [FilePath]
loggingConduit ConduitT ByteString Void IO [FilePath]
forall c. ConduitM ByteString c IO [FilePath]
loggingConduit
    FilePath
res <- FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
output_file IOMode
ReadMode ((Handle -> IO FilePath) -> IO FilePath)
-> (Handle -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \handle :: Handle
handle -> do
             Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering
             !FilePath
res <- FilePath -> FilePath
forall a. NFData a => a -> a
force (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO FilePath
hGetContents Handle
handle
             FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
res

    (ExitCode, [FilePath], [FilePath], [FilePath])
-> IO (ExitCode, [FilePath], [FilePath], [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, [FilePath]
stdo, [FilePath]
stde, FilePath -> [FilePath]
lines ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\r') FilePath
res))

    where
      withHieBiosOutput :: [(String,String)] -> (FilePath -> IO a) -> IO a
      withHieBiosOutput :: [(FilePath, FilePath)] -> (FilePath -> IO a) -> IO a
withHieBiosOutput env' :: [(FilePath, FilePath)]
env' action :: FilePath -> IO a
action = do
        let mbHieBiosOut :: Maybe FilePath
mbHieBiosOut = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
hieBiosOutput [(FilePath, FilePath)]
env'
        case Maybe FilePath
mbHieBiosOut of
          Just file :: FilePath
file@(_:_) -> FilePath -> IO a
action FilePath
file
          _ -> FilePath -> (FilePath -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile "hie-bios" ((FilePath -> Handle -> IO a) -> IO a)
-> (FilePath -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
                 \ file :: FilePath
file h :: Handle
h -> Handle -> IO ()
hClose Handle
h IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO a
action FilePath
file

      hieBiosOutput :: FilePath
hieBiosOutput = "HIE_BIOS_OUTPUT"

makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult :: (ExitCode, [FilePath], FilePath, [FilePath])
-> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult (ex :: ExitCode
ex, err :: [FilePath]
err, componentDir :: FilePath
componentDir, gopts :: [FilePath]
gopts) deps :: [FilePath]
deps =
  case ExitCode
ex of
    ExitFailure _ -> CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail ([FilePath] -> ExitCode -> [FilePath] -> CradleError
CradleError [FilePath]
deps ExitCode
ex [FilePath]
err)
    _ ->
        let compOpts :: ComponentOptions
compOpts = [FilePath] -> FilePath -> [FilePath] -> ComponentOptions
ComponentOptions [FilePath]
gopts FilePath
componentDir [FilePath]
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 :: FilePath -> [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmdOnPath wdir :: FilePath
wdir args :: [FilePath]
args = FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd FilePath
wdir "ghc" [FilePath]
args ""
  -- case mResult of
  --   Nothing

-- | Wrapper around 'readCreateProcess' that sets the working directory
readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO (CradleLoadResult String)
readProcessWithCwd :: FilePath
-> FilePath
-> [FilePath]
-> FilePath
-> IO (CradleLoadResult FilePath)
readProcessWithCwd dir :: FilePath
dir cmd :: FilePath
cmd args :: [FilePath]
args stdi :: FilePath
stdi = do
  [(FilePath, FilePath)]
cleanEnv <- IO [(FilePath, FilePath)]
getCleanEnvironment
  let createProc :: CreateProcess
createProc = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args) { cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir, env :: Maybe [(FilePath, FilePath)]
env = [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
cleanEnv }
  Maybe (ExitCode, FilePath, FilePath)
mResult <- IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (IO (ExitCode, FilePath, FilePath)
 -> IO (Maybe (ExitCode, FilePath, FilePath)))
-> IO (ExitCode, FilePath, FilePath)
-> IO (Maybe (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$ CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode CreateProcess
createProc FilePath
stdi
  case Maybe (ExitCode, FilePath, FilePath)
mResult of
    Just (ExitSuccess, stdo :: FilePath
stdo, _) -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult FilePath -> IO (CradleLoadResult FilePath))
-> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> CradleLoadResult FilePath
forall r. r -> CradleLoadResult r
CradleSuccess FilePath
stdo
    Just (exitCode :: ExitCode
exitCode, stdo :: FilePath
stdo, stde :: FilePath
stde) -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult FilePath -> IO (CradleLoadResult FilePath))
-> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$ CradleError -> CradleLoadResult FilePath
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError -> CradleLoadResult FilePath)
-> CradleError -> CradleLoadResult FilePath
forall a b. (a -> b) -> a -> b
$
      [FilePath] -> ExitCode -> [FilePath] -> CradleError
CradleError [] ExitCode
exitCode ["Error when calling " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
cmd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> " " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unwords [FilePath]
args, FilePath
stdo, FilePath
stde]
    Nothing -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult FilePath -> IO (CradleLoadResult FilePath))
-> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$ CradleError -> CradleLoadResult FilePath
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError -> CradleLoadResult FilePath)
-> CradleError -> CradleLoadResult FilePath
forall a b. (a -> b) -> a -> b
$
      [FilePath] -> ExitCode -> [FilePath] -> CradleError
CradleError [] ExitCode
ExitSuccess ["Couldn't execute " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
cmd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> " " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unwords [FilePath]
args]