{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RecordWildCards #-}
module HIE.Bios.Cradle (
      findCradle
    , loadCradle
    , loadImplicitCradle
    , yamlConfig
    , defaultCradle
    , isCabalCradle
    , isStackCradle
    , isDirectCradle
    , isBiosCradle
    , isNoneCradle
    , isMultiCradle
    , isDefaultCradle
    , isOtherCradle
    , getCradle
    , Process.readProcessWithOutputs
    , Process.readProcessWithCwd
    , makeCradleResult
    -- | Cradle project configuration types
    , CradleProjectConfig(..)
  ) where

import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import qualified Data.Yaml as Yaml
import Data.Version
import Data.Void
import Data.Bifunctor (first)
import Data.Conduit.Process
import Data.Maybe (fromMaybe)
import Data.List
import Data.Ord (Down(..))
import qualified Data.Text as T
import System.Environment
import System.Exit
import System.FilePath
import System.Directory
import System.IO (hClose, hPutStr)
import System.IO.Temp

import HIE.Bios.Config
import HIE.Bios.Types hiding (ActionName(..))
import qualified HIE.Bios.Process as Process
import qualified HIE.Bios.Types as Types
import qualified HIE.Bios.Ghc.Gap as Gap
import HIE.Bios.Cradle.ProjectConfig
import HIE.Bios.Cradle.Utils
import HIE.Bios.Cradle.Cabal as Cabal
import HIE.Bios.Cradle.Resolved
import HIE.Bios.Cradle.ProgramVersions

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

-- | Given @root\/foo\/bar.hs@, return @root\/hie.yaml@, or wherever the yaml file was found.
--
-- Note, 'findCradle' used to **not** work for directories and required a Haskell file.
-- This has been fixed since @0.14.0@.
-- However, 'loadCradle' and 'loadImplicitCradle' still require a Haskell
-- source file and won't work properly with a directory parameter.
findCradle :: FilePath -> IO (Maybe FilePath)
findCradle :: String -> IO (Maybe String)
findCradle String
wfile = do
    String
wdir <- String -> IO Bool
doesDirectoryExist String
wfile IO Bool -> (Bool -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True ->  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
wfile
      Bool
False -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle Void)
loadCradle :: LogAction IO (WithSeverity Log) -> String -> IO (Cradle Void)
loadCradle LogAction IO (WithSeverity Log)
l = LogAction IO (WithSeverity Log)
-> (Void -> CradleAction Void) -> String -> IO (Cradle Void)
forall b a.
(FromJSON b, Show a) =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a) -> String -> IO (Cradle a)
loadCradleWithOpts LogAction IO (WithSeverity Log)
l Void -> CradleAction Void
forall a. Void -> a
absurd

-- | Given root\/foo\/bar.hs, load an implicit cradle
loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)
loadImplicitCradle :: forall a.
Show a =>
LogAction IO (WithSeverity Log) -> String -> IO (Cradle a)
loadImplicitCradle LogAction IO (WithSeverity Log)
l 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)
  case Maybe (CradleConfig Void, String)
cfg of
    Just (CradleConfig Void, String)
bc -> LogAction IO (WithSeverity Log)
-> (Void -> CradleAction a)
-> (CradleConfig Void, String)
-> IO (Cradle a)
forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> (CradleConfig b, String)
-> IO (Cradle a)
getCradle LogAction IO (WithSeverity Log)
l Void -> CradleAction a
forall a. Void -> a
absurd (CradleConfig Void, String)
bc
    Maybe (CradleConfig Void, String)
Nothing -> Cradle a -> IO (Cradle a)
forall a. a -> IO 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
$ LogAction IO (WithSeverity Log) -> String -> Cradle a
forall a. LogAction IO (WithSeverity Log) -> String -> Cradle a
defaultCradle LogAction IO (WithSeverity Log)
l 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, Show a) => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a)
loadCradleWithOpts :: forall b a.
(FromJSON b, Show a) =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a) -> String -> IO (Cradle a)
loadCradleWithOpts LogAction IO (WithSeverity Log)
l b -> CradleAction a
buildCustomCradle String
wfile = do
    CradleConfig b
cradleConfig <- String -> IO (CradleConfig b)
forall b. FromJSON b => String -> IO (CradleConfig b)
readCradleConfig String
wfile
    LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> (CradleConfig b, String)
-> IO (Cradle a)
forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> (CradleConfig b, String)
-> IO (Cradle a)
getCradle LogAction IO (WithSeverity Log)
l b -> CradleAction a
buildCustomCradle (CradleConfig b
cradleConfig, String -> String
takeDirectory String
wfile)

getCradle :: Show a => LogAction IO (WithSeverity Log) ->  (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a)
getCradle :: forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> (CradleConfig b, String)
-> IO (Cradle a)
getCradle LogAction IO (WithSeverity Log)
l b -> CradleAction a
buildCustomCradle (CradleConfig b
cc, String
wdir) = do
    [ResolvedCradle b]
rcs <- String -> [ResolvedCradle b] -> IO [ResolvedCradle b]
forall a. String -> [ResolvedCradle a] -> IO [ResolvedCradle a]
canonicalizeResolvedCradles String
wdir [ResolvedCradle b]
cs
    LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> String
-> [ResolvedCradle b]
-> IO (Cradle a)
forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> String
-> [ResolvedCradle b]
-> IO (Cradle a)
resolvedCradlesToCradle LogAction IO (WithSeverity Log)
l b -> CradleAction a
buildCustomCradle String
wdir [ResolvedCradle b]
rcs
  where
    cs :: [ResolvedCradle b]
cs = String -> CradleConfig b -> [ResolvedCradle b]
forall a. String -> CradleConfig a -> [ResolvedCradle a]
resolveCradleTree String
wdir CradleConfig b
cc

addActionDeps :: [FilePath] -> CradleLoadResult ComponentOptions -> CradleLoadResult ComponentOptions
addActionDeps :: [String]
-> CradleLoadResult ComponentOptions
-> CradleLoadResult ComponentOptions
addActionDeps [String]
deps =
  CradleLoadResult ComponentOptions
-> (CradleError -> CradleLoadResult ComponentOptions)
-> (ComponentOptions -> CradleLoadResult ComponentOptions)
-> CradleLoadResult ComponentOptions
-> CradleLoadResult ComponentOptions
forall c r.
c -> (CradleError -> c) -> (r -> c) -> CradleLoadResult r -> c
cradleLoadResult
      CradleLoadResult ComponentOptions
forall r. CradleLoadResult r
CradleNone
      (\CradleError
err -> CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError
err { cradleErrorDependencies = cradleErrorDependencies err `union` deps }))
      (\(ComponentOptions [String]
os' String
dir [String]
ds) -> ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess ([String] -> String -> [String] -> ComponentOptions
ComponentOptions [String]
os' String
dir ([String]
ds [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`union` [String]
deps)))


resolvedCradlesToCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> [ResolvedCradle b] -> IO (Cradle a)
resolvedCradlesToCradle :: forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> String
-> [ResolvedCradle b]
-> IO (Cradle a)
resolvedCradlesToCradle LogAction IO (WithSeverity Log)
logger b -> CradleAction a
buildCustomCradle String
root [ResolvedCradle b]
cs = mdo
  let run_ghc_cmd :: [String] -> IO (CradleLoadResult String)
run_ghc_cmd [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 (CradleAction a -> Bool) -> [CradleAction a] -> [CradleAction a]
forall a. (a -> Bool) -> [a] -> [a]
filter (ActionName a -> Bool
forall {a}. ActionName a -> Bool
notNoneType (ActionName a -> Bool)
-> (CradleAction a -> ActionName a) -> CradleAction a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName) ([CradleAction a] -> [CradleAction a])
-> [CradleAction a] -> [CradleAction a]
forall a b. (a -> b) -> a -> b
$ ((ResolvedCradle b, CradleAction a) -> CradleAction a)
-> [(ResolvedCradle b, CradleAction a)] -> [CradleAction a]
forall a b. (a -> b) -> [a] -> [b]
map (ResolvedCradle b, CradleAction a) -> CradleAction a
forall a b. (a, b) -> b
snd [(ResolvedCradle b, CradleAction a)]
cradleActions of
          [] -> CradleLoadResult String -> IO (CradleLoadResult String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CradleLoadResult String
forall r. CradleLoadResult r
CradleNone
          (CradleAction a
act:[CradleAction a]
_) ->
            CradleAction a -> [String] -> IO (CradleLoadResult String)
forall a.
CradleAction a -> [String] -> IO (CradleLoadResult String)
runGhcCmd
              CradleAction a
act
              [String]
args
  ProgramVersions
versions <- LogAction IO (WithSeverity Log)
-> String
-> ([String] -> IO (CradleLoadResult String))
-> IO ProgramVersions
makeVersions LogAction IO (WithSeverity Log)
logger String
root [String] -> IO (CradleLoadResult String)
run_ghc_cmd
  let rcs :: ResolvedCradles b
rcs = String
-> [ResolvedCradle b] -> ProgramVersions -> ResolvedCradles b
forall a.
String
-> [ResolvedCradle a] -> ProgramVersions -> ResolvedCradles a
ResolvedCradles String
root [ResolvedCradle b]
cs ProgramVersions
versions
      cradleActions :: [(ResolvedCradle b, CradleAction a)]
cradleActions = [ (ResolvedCradle b
c, LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> ResolvedCradles b
-> String
-> ResolvedCradle b
-> CradleAction a
forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> ResolvedCradles b
-> String
-> ResolvedCradle b
-> CradleAction a
resolveCradleAction LogAction IO (WithSeverity Log)
logger b -> CradleAction a
buildCustomCradle ResolvedCradles b
rcs String
root ResolvedCradle b
c) | ResolvedCradle b
c <- [ResolvedCradle b]
cs ]
      err_msg :: String -> [String]
err_msg String
fp
        = [String
"Multi Cradle: No prefixes matched"
          , String
"pwd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
root
          , String
"filepath: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
          , String
"prefixes:"
          ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(String, ActionName a) -> String
forall a. Show a => a -> String
show (ResolvedCradle b -> String
forall a. ResolvedCradle a -> String
prefix ResolvedCradle b
pf, CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName CradleAction a
cc) | (ResolvedCradle b
pf, CradleAction a
cc) <- [(ResolvedCradle b, CradleAction a)]
cradleActions]
  Cradle a -> IO (Cradle a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cradle a -> IO (Cradle a)) -> Cradle a -> IO (Cradle a)
forall a b. (a -> b) -> a -> b
$ Cradle
    { cradleRootDir :: String
cradleRootDir = String
root
    , cradleLogger :: LogAction IO (WithSeverity Log)
cradleLogger = LogAction IO (WithSeverity Log)
logger
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction
      { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
multiActionName
      , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle  = \String
fp LoadStyle
prev -> do
          String
absfp <- String -> IO String
makeAbsolute String
fp
          case ((ResolvedCradle b, CradleAction a) -> String)
-> String
-> [(ResolvedCradle b, CradleAction a)]
-> Maybe (ResolvedCradle b, CradleAction a)
forall a. (a -> String) -> String -> [a] -> Maybe a
selectCradle (ResolvedCradle b -> String
forall a. ResolvedCradle a -> String
prefix (ResolvedCradle b -> String)
-> ((ResolvedCradle b, CradleAction a) -> ResolvedCradle b)
-> (ResolvedCradle b, CradleAction a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResolvedCradle b, CradleAction a) -> ResolvedCradle b
forall a b. (a, b) -> a
fst) String
absfp [(ResolvedCradle b, CradleAction a)]
cradleActions of
            Just (ResolvedCradle b
rc, CradleAction a
act) -> do
              [String]
-> CradleLoadResult ComponentOptions
-> CradleLoadResult ComponentOptions
addActionDeps (ResolvedCradle b -> [String]
forall a. ResolvedCradle a -> [String]
cradleDeps ResolvedCradle b
rc) (CradleLoadResult ComponentOptions
 -> CradleLoadResult ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CradleAction a
-> String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle CradleAction a
act String
fp LoadStyle
prev
            Maybe (ResolvedCradle b, CradleAction a)
Nothing -> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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
$ CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail (CradleError -> CradleLoadResult ComponentOptions)
-> CradleError -> CradleLoadResult ComponentOptions
forall a b. (a -> b) -> a -> b
$ [String] -> ExitCode -> [String] -> [String] -> CradleError
CradleError [] ExitCode
ExitSuccess (String -> [String]
err_msg String
fp) [String
fp]
      , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = [String] -> IO (CradleLoadResult String)
run_ghc_cmd
      }
    }
  where
    multiActionName :: ActionName a
multiActionName
      | (ResolvedCradle b -> Bool) -> [ResolvedCradle b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ResolvedCradle b
c -> ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isStackCradleConfig ResolvedCradle b
c Bool -> Bool -> Bool
|| ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isNoneCradleConfig ResolvedCradle b
c) [ResolvedCradle b]
cs
      = ActionName a
forall {a}. ActionName a
Types.Stack
      | (ResolvedCradle b -> Bool) -> [ResolvedCradle b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ResolvedCradle b
c -> ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isCabalCradleConfig ResolvedCradle b
c Bool -> Bool -> Bool
|| ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isNoneCradleConfig ResolvedCradle b
c) [ResolvedCradle b]
cs
      = ActionName a
forall {a}. ActionName a
Types.Cabal
      | [Bool
True] <- (ResolvedCradle b -> Bool) -> [ResolvedCradle b] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isBiosCradleConfig ([ResolvedCradle b] -> [Bool]) -> [ResolvedCradle b] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (ResolvedCradle b -> Bool)
-> [ResolvedCradle b] -> [ResolvedCradle b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ResolvedCradle b -> Bool) -> ResolvedCradle b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isNoneCradleConfig) [ResolvedCradle b]
cs
      = ActionName a
forall {a}. ActionName a
Types.Bios
      | [Bool
True] <- (ResolvedCradle b -> Bool) -> [ResolvedCradle b] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isDirectCradleConfig ([ResolvedCradle b] -> [Bool]) -> [ResolvedCradle b] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (ResolvedCradle b -> Bool)
-> [ResolvedCradle b] -> [ResolvedCradle b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ResolvedCradle b -> Bool) -> ResolvedCradle b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedCradle b -> Bool
forall {a}. ResolvedCradle a -> Bool
isNoneCradleConfig) [ResolvedCradle b]
cs
      = ActionName a
forall {a}. ActionName a
Types.Direct
      | Bool
otherwise
      = ActionName a
forall {a}. ActionName a
Types.Multi

    isStackCradleConfig :: ResolvedCradle a -> Bool
isStackCradleConfig ResolvedCradle a
cfg = case ResolvedCradle a -> ConcreteCradle a
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle a
cfg of
      ConcreteStack{} -> Bool
True
      ConcreteCradle a
_               -> Bool
False

    isCabalCradleConfig :: ResolvedCradle a -> Bool
isCabalCradleConfig ResolvedCradle a
cfg = case ResolvedCradle a -> ConcreteCradle a
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle a
cfg of
      ConcreteCabal{} -> Bool
True
      ConcreteCradle a
_               -> Bool
False

    isBiosCradleConfig :: ResolvedCradle a -> Bool
isBiosCradleConfig ResolvedCradle a
cfg = case ResolvedCradle a -> ConcreteCradle a
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle a
cfg of
      ConcreteBios{}  -> Bool
True
      ConcreteCradle a
_               -> Bool
False

    isDirectCradleConfig :: ResolvedCradle a -> Bool
isDirectCradleConfig ResolvedCradle a
cfg = case ResolvedCradle a -> ConcreteCradle a
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle a
cfg of
      ConcreteDirect{} -> Bool
True
      ConcreteCradle a
_                -> Bool
False

    isNoneCradleConfig :: ResolvedCradle a -> Bool
isNoneCradleConfig ResolvedCradle a
cfg = case ResolvedCradle a -> ConcreteCradle a
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle a
cfg of
      ConcreteNone{} -> Bool
True
      ConcreteCradle a
_              -> Bool
False

    notNoneType :: ActionName a -> Bool
notNoneType ActionName a
Types.None = Bool
False
    notNoneType ActionName a
_ = Bool
True


resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
resolveCradleAction :: forall a b.
Show a =>
LogAction IO (WithSeverity Log)
-> (b -> CradleAction a)
-> ResolvedCradles b
-> String
-> ResolvedCradle b
-> CradleAction a
resolveCradleAction LogAction IO (WithSeverity Log)
l b -> CradleAction a
buildCustomCradle ResolvedCradles b
cs String
root ResolvedCradle b
cradle = CradleAction a -> CradleAction a
forall {a}. Show a => CradleAction a -> CradleAction a
addLoadStyleLogToCradleAction (CradleAction a -> CradleAction a)
-> CradleAction a -> CradleAction a
forall a b. (a -> b) -> a -> b
$
  case ResolvedCradle b -> ConcreteCradle b
forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle ResolvedCradle b
cradle of
    ConcreteCabal CabalType
t -> LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Maybe String
-> CradleProjectConfig
-> CradleAction a
forall b a.
LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Maybe String
-> CradleProjectConfig
-> CradleAction a
cabalCradle LogAction IO (WithSeverity Log)
l ResolvedCradles b
cs String
root (CabalType -> Maybe String
cabalComponent CabalType
t) (String -> Maybe String -> CradleProjectConfig
projectConfigFromMaybe String
root (CabalType -> Maybe String
cabalProjectFile CabalType
t))
    ConcreteStack StackType
t -> LogAction IO (WithSeverity Log)
-> String -> Maybe String -> CradleProjectConfig -> CradleAction a
forall a.
LogAction IO (WithSeverity Log)
-> String -> Maybe String -> CradleProjectConfig -> CradleAction a
stackCradle LogAction IO (WithSeverity Log)
l String
root (StackType -> Maybe String
stackComponent StackType
t) (String -> Maybe String -> CradleProjectConfig
projectConfigFromMaybe String
root (StackType -> Maybe String
stackYaml StackType
t))
    ConcreteBios Callable
bios Maybe Callable
deps Maybe String
mbGhc -> LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Callable
-> Maybe Callable
-> Maybe String
-> CradleAction a
forall b a.
LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Callable
-> Maybe Callable
-> Maybe String
-> CradleAction a
biosCradle LogAction IO (WithSeverity Log)
l ResolvedCradles b
cs String
root Callable
bios Maybe Callable
deps Maybe String
mbGhc
    ConcreteDirect [String]
xs -> LogAction IO (WithSeverity Log)
-> String -> [String] -> CradleAction a
forall a.
LogAction IO (WithSeverity Log)
-> String -> [String] -> CradleAction a
directCradle LogAction IO (WithSeverity Log)
l String
root [String]
xs
    ConcreteCradle b
ConcreteNone -> CradleAction a
forall a. CradleAction a
noneCradle
    ConcreteOther b
a -> b -> CradleAction a
buildCustomCradle b
a
  where
    -- Add a log message to each loading operation.
    addLoadStyleLogToCradleAction :: CradleAction a -> CradleAction a
addLoadStyleLogToCradleAction CradleAction a
crdlAct = CradleAction a
crdlAct
      { runCradle = \String
fp LoadStyle
ls -> do
          LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> LoadStyle -> Log
LogRequestedCradleLoadStyle (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ActionName a -> String
forall a. Show a => a -> String
show (ActionName a -> String) -> ActionName a -> String
forall a b. (a -> b) -> a -> b
$ CradleAction a -> ActionName a
forall a. CradleAction a -> ActionName a
actionName CradleAction a
crdlAct) LoadStyle
ls Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
          CradleAction a
-> String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
forall a.
CradleAction a
-> String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle CradleAction a
crdlAct String
fp LoadStyle
ls
      }

resolveCradleTree :: FilePath -> CradleConfig a -> [ResolvedCradle a]
resolveCradleTree :: forall a. String -> CradleConfig a -> [ResolvedCradle a]
resolveCradleTree String
root (CradleConfig [String]
confDeps CradleTree a
confTree) = String -> [String] -> CradleTree a -> [ResolvedCradle a]
forall {a}.
String -> [String] -> CradleTree a -> [ResolvedCradle a]
go String
root [String]
confDeps CradleTree a
confTree
  where
    go :: String -> [String] -> CradleTree a -> [ResolvedCradle a]
go String
pfix [String]
deps CradleTree a
tree = case CradleTree a
tree of
      Cabal CabalType
t              -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps (CabalType -> ConcreteCradle a
forall a. CabalType -> ConcreteCradle a
ConcreteCabal CabalType
t)]
      Stack StackType
t              -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps (StackType -> ConcreteCradle a
forall a. StackType -> ConcreteCradle a
ConcreteStack StackType
t)]
      Bios Callable
bios Maybe Callable
dcmd Maybe String
mbGhc -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps (Callable -> Maybe Callable -> Maybe String -> ConcreteCradle a
forall a.
Callable -> Maybe Callable -> Maybe String -> ConcreteCradle a
ConcreteBios Callable
bios Maybe Callable
dcmd Maybe String
mbGhc)]
      Direct [String]
xs            -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps ([String] -> ConcreteCradle a
forall a. [String] -> ConcreteCradle a
ConcreteDirect [String]
xs)]
      CradleTree a
None                 -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps ConcreteCradle a
forall a. ConcreteCradle a
ConcreteNone]
      Other a
a Value
_            -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
pfix [String]
deps (a -> ConcreteCradle a
forall a. a -> ConcreteCradle a
ConcreteOther a
a)]
      CabalMulti CabalType
dc [(String, CabalType)]
xs     -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
p    [String]
deps (CabalType -> ConcreteCradle a
forall a. CabalType -> ConcreteCradle a
ConcreteCabal (CabalType
dc CabalType -> CabalType -> CabalType
forall a. Semigroup a => a -> a -> a
<> CabalType
c)) | (String
p, CabalType
c) <- [(String, CabalType)]
xs ]
      StackMulti StackType
dc [(String, StackType)]
xs     -> [String -> [String] -> ConcreteCradle a -> ResolvedCradle a
forall a.
String -> [String] -> ConcreteCradle a -> ResolvedCradle a
ResolvedCradle String
p    [String]
deps (StackType -> ConcreteCradle a
forall a. StackType -> ConcreteCradle a
ConcreteStack (StackType
dc StackType -> StackType -> StackType
forall a. Semigroup a => a -> a -> a
<> StackType
c)) | (String
p, StackType
c) <- [(String, StackType)]
xs ]
      Multi [(String, CradleConfig a)]
xs             -> [[ResolvedCradle a]] -> [ResolvedCradle a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String -> [String] -> CradleTree a -> [ResolvedCradle a]
go String
pfix' ([String]
deps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
deps') CradleTree a
tree' | (String
pfix', CradleConfig [String]
deps' CradleTree a
tree') <- [(String, CradleConfig a)]
xs]

-- | 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
inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath)
inferCradleTree :: forall a. String -> MaybeT IO (CradleTree a, String)
inferCradleTree String
fp =
       MaybeT IO (CradleTree a, String)
forall {a}. MaybeT IO (CradleTree a, String)
maybeItsBios
   MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleTree a, String)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO (CradleTree a, String)
forall {a}. MaybeT IO (CradleTree a, String)
maybeItsStack
   MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleTree a, String)
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO (CradleTree a, String)
forall {a}. MaybeT IO (CradleTree a, String)
maybeItsCabal
-- <|> maybeItsObelisk
-- <|> maybeItsObelisk

  where
  maybeItsBios :: MaybeT IO (CradleTree a, String)
maybeItsBios = (\String
wdir -> (Callable -> Maybe Callable -> Maybe String -> CradleTree a
forall a.
Callable -> Maybe Callable -> Maybe String -> CradleTree 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 -> (CradleTree a, String))
-> MaybeT IO String -> MaybeT IO (CradleTree a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
biosWorkDir String
fp

  maybeItsStack :: MaybeT IO (CradleTree a, String)
maybeItsStack = MaybeT IO String
stackExecutable MaybeT IO String
-> MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleTree a, String)
forall a b. MaybeT IO a -> MaybeT IO b -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (StackType -> CradleTree a
forall a. StackType -> CradleTree a
Stack (StackType -> CradleTree a) -> StackType -> CradleTree 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 -> (CradleTree a, String))
-> MaybeT IO String -> MaybeT IO (CradleTree a, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
stackWorkDir String
fp

  maybeItsCabal :: MaybeT IO (CradleTree a, String)
maybeItsCabal = (CabalType -> CradleTree a
forall a. CabalType -> CradleTree a
Cabal (CabalType -> CradleTree a) -> CabalType -> CradleTree a
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> CabalType
CabalType Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing,) (String -> (CradleTree a, String))
-> MaybeT IO String -> MaybeT IO (CradleTree 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 @inferCradleTree@ as a @CradleConfig@ with no dependencies
implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath)
implicitConfig :: forall a. String -> MaybeT IO (CradleConfig a, String)
implicitConfig = (((CradleTree a, String) -> (CradleConfig a, String))
-> MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleConfig a, String)
forall a b. (a -> b) -> MaybeT IO a -> MaybeT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CradleTree a, String) -> (CradleConfig a, String))
 -> MaybeT IO (CradleTree a, String)
 -> MaybeT IO (CradleConfig a, String))
-> ((CradleTree a -> CradleConfig a)
    -> (CradleTree a, String) -> (CradleConfig a, String))
-> (CradleTree a -> CradleConfig a)
-> MaybeT IO (CradleTree a, String)
-> MaybeT IO (CradleConfig a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CradleTree a -> CradleConfig a)
-> (CradleTree a, String) -> (CradleConfig a, String)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) ([String] -> CradleTree a -> CradleConfig a
forall a. [String] -> CradleTree a -> CradleConfig a
CradleConfig [String]
noDeps) (MaybeT IO (CradleTree a, String)
 -> MaybeT IO (CradleConfig a, String))
-> (String -> MaybeT IO (CradleTree a, String))
-> String
-> MaybeT IO (CradleConfig a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MaybeT IO (CradleTree a, String)
forall a. String -> MaybeT IO (CradleTree a, String)
inferCradleTree
  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 a. a -> MaybeT IO a
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 -> String -> MaybeT IO String
Process.findFileUpwards String
configFileName

readCradleConfig :: Yaml.FromJSON b => FilePath -> IO (CradleConfig b)
readCradleConfig :: forall b. FromJSON b => String -> IO (CradleConfig b)
readCradleConfig String
yamlHie = do
  Config b
cfg  <- IO (Config b) -> IO (Config b)
forall a. IO a -> IO a
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 a. a -> IO a
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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: LogAction IO (WithSeverity Log) -> FilePath -> Cradle a
defaultCradle :: forall a. LogAction IO (WithSeverity Log) -> String -> Cradle a
defaultCradle LogAction IO (WithSeverity Log)
l String
cur_dir =
  Cradle
    { cradleRootDir :: String
cradleRootDir = String
cur_dir
    , cradleLogger :: LogAction IO (WithSeverity Log)
cradleLogger = LogAction IO (WithSeverity Log)
l
    , cradleOptsProg :: CradleAction a
cradleOptsProg = CradleAction
        { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
Types.Default
        , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle = \String
_ LoadStyle
_ ->
            CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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 = LogAction IO (WithSeverity Log)
-> String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath LogAction IO (WithSeverity Log)
l String
cur_dir
        }
    }

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

noneCradle :: CradleAction a
noneCradle :: forall a. CradleAction a
noneCradle =
  CradleAction
      { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
Types.None
      , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle = \String
_ LoadStyle
_ -> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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 a. a -> IO a
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
--
-- 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.
canonicalizeResolvedCradles :: FilePath -> [ResolvedCradle a] -> IO [ResolvedCradle a]
canonicalizeResolvedCradles :: forall a. String -> [ResolvedCradle a] -> IO [ResolvedCradle a]
canonicalizeResolvedCradles String
cur_dir [ResolvedCradle a]
cs =
  (ResolvedCradle a -> Down String)
-> [ResolvedCradle a] -> [ResolvedCradle a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String -> Down String
forall a. a -> Down a
Down (String -> Down String)
-> (ResolvedCradle a -> String) -> ResolvedCradle a -> Down String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedCradle a -> String
forall a. ResolvedCradle a -> String
prefix)
    ([ResolvedCradle a] -> [ResolvedCradle a])
-> IO [ResolvedCradle a] -> IO [ResolvedCradle a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResolvedCradle a -> IO (ResolvedCradle a))
-> [ResolvedCradle a] -> IO [ResolvedCradle a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ResolvedCradle a
c -> (\String
abs_fp -> ResolvedCradle a
c {prefix = abs_fp}) (String -> ResolvedCradle a) -> IO String -> IO (ResolvedCradle a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute (String
cur_dir String -> String -> String
</> ResolvedCradle a -> String
forall a. ResolvedCradle a -> String
prefix ResolvedCradle a
c)) [ResolvedCradle a]
cs

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

directCradle :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> CradleAction a
directCradle :: forall a.
LogAction IO (WithSeverity Log)
-> String -> [String] -> CradleAction a
directCradle LogAction IO (WithSeverity Log)
l String
wdir [String]
args
  = CradleAction
      { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
Types.Direct
      , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle = \String
_ LoadStyle
loadStyle -> do
          LogAction IO (WithSeverity Log) -> LoadStyle -> Text -> IO ()
forall (m :: * -> *).
Applicative m =>
LogAction m (WithSeverity Log) -> LoadStyle -> Text -> m ()
logCradleHasNoSupportForLoadWithContext LogAction IO (WithSeverity Log)
l LoadStyle
loadStyle Text
"direct"
          CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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 = LogAction IO (WithSeverity Log)
-> String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath LogAction IO (WithSeverity Log)
l 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 :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Callable -> Maybe Callable -> Maybe FilePath -> CradleAction a
biosCradle :: forall b a.
LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Callable
-> Maybe Callable
-> Maybe String
-> CradleAction a
biosCradle LogAction IO (WithSeverity Log)
l ResolvedCradles b
rc String
wdir Callable
biosCall Maybe Callable
biosDepsCall Maybe String
mbGhc
  = CradleAction
      { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
Types.Bios
      , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle = ResolvedCradles b
-> String
-> Callable
-> Maybe Callable
-> LogAction IO (WithSeverity Log)
-> String
-> LoadStyle
-> IO (CradleLoadResult ComponentOptions)
forall a.
ResolvedCradles a
-> String
-> Callable
-> Maybe Callable
-> LogAction IO (WithSeverity Log)
-> String
-> LoadStyle
-> IO (CradleLoadResult ComponentOptions)
biosAction ResolvedCradles b
rc String
wdir Callable
biosCall Maybe Callable
biosDepsCall LogAction IO (WithSeverity Log)
l
      , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = \[String]
args -> LogAction IO (WithSeverity Log)
-> String
-> String
-> [String]
-> String
-> IO (CradleLoadResult String)
Process.readProcessWithCwd LogAction IO (WithSeverity Log)
l 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 -> String -> MaybeT IO String
Process.findFileUpwards String
".hie-bios"

biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> LoadStyle -> IO [FilePath]
biosDepsAction :: LogAction IO (WithSeverity Log)
-> String -> Maybe Callable -> String -> LoadStyle -> IO [String]
biosDepsAction LogAction IO (WithSeverity Log)
l String
wdir (Just Callable
biosDepsCall) String
fp LoadStyle
loadStyle = do
  let fps :: [String]
fps = case LoadStyle
loadStyle of
        LoadStyle
LoadFile -> [String
fp]
        LoadWithContext [String]
old_fps -> String
fp String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
old_fps
  (ExitCode
ex, [String]
sout, [String]
serr, [(String
_, Maybe [String]
args)]) <-
    ContT
  (ExitCode, [String], [String], [(String, Maybe [String])])
  IO
  CreateProcess
-> (CreateProcess
    -> 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 (Callable
-> [String]
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     CreateProcess
forall a. Callable -> [String] -> ContT a IO CreateProcess
withCallableToProcess Callable
biosDepsCall [String]
fps) ((CreateProcess
  -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> (CreateProcess
    -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ \CreateProcess
biosDeps' ->
      [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
Process.readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
wdir CreateProcess
biosDeps'
  case ExitCode
ex of
    ExitFailure Int
_ ->  String -> IO [String]
forall a. HasCallStack => String -> a
error (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ (ExitCode, [String], [String]) -> String
forall a. Show a => a -> String
show (ExitCode
ex, [String]
sout, [String]
serr)
    ExitCode
ExitSuccess -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
args
biosDepsAction LogAction IO (WithSeverity Log)
_ String
_ Maybe Callable
Nothing String
_ LoadStyle
_ = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

biosAction
  :: ResolvedCradles a
  -> FilePath
  -> Callable
  -> Maybe Callable
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> LoadStyle
  -> IO (CradleLoadResult ComponentOptions)
biosAction :: forall a.
ResolvedCradles a
-> String
-> Callable
-> Maybe Callable
-> LogAction IO (WithSeverity Log)
-> String
-> LoadStyle
-> IO (CradleLoadResult ComponentOptions)
biosAction ResolvedCradles a
rc String
wdir Callable
bios Maybe Callable
bios_deps LogAction IO (WithSeverity Log)
l String
fp LoadStyle
loadStyle = do
  Maybe Version
ghc_version <- IO (Maybe Version) -> IO (Maybe Version)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ CachedIO (Maybe Version) -> IO (Maybe Version)
forall a. CachedIO a -> IO a
runCachedIO (CachedIO (Maybe Version) -> IO (Maybe Version))
-> CachedIO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ProgramVersions -> CachedIO (Maybe Version)
ghcVersion (ProgramVersions -> CachedIO (Maybe Version))
-> ProgramVersions -> CachedIO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ResolvedCradles a -> ProgramVersions
forall a. ResolvedCradles a -> ProgramVersions
cradleProgramVersions ResolvedCradles a
rc
  LoadStyle
determinedLoadStyle <- case Maybe Version
ghc_version of
    Just Version
ghc
      -- Multi-component supported from ghc 9.4
      -- We trust the assertion for a bios program, as we have no way of
      -- checking its version
      | LoadWithContext [String]
_ <- LoadStyle
loadStyle ->
          if Version
ghc Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
makeVersion [Int
9,Int
4]
            then LoadStyle -> IO LoadStyle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadStyle
loadStyle
            else do
              IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity
                (Text -> Maybe Text -> Log
LogLoadWithContextUnsupported Text
"bios"
                  (Maybe Text -> Log) -> Maybe Text -> Log
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ghc version is too old. We require `ghc >= 9.4`"
                )
                Severity
Warning
              LoadStyle -> IO LoadStyle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadStyle
LoadFile
    Maybe Version
_ -> LoadStyle -> IO LoadStyle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadStyle
LoadFile
  let fps :: [String]
fps = case LoadStyle
determinedLoadStyle of
        LoadStyle
LoadFile -> [String
fp]
        LoadWithContext [String]
old_fps -> String
fp String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
old_fps
  (ExitCode
ex, [String]
_stdo, [String]
std, [(String
_, Maybe [String]
res),(String
_, Maybe [String]
mb_deps)]) <-
    ContT
  (ExitCode, [String], [String], [(String, Maybe [String])])
  IO
  CreateProcess
-> (CreateProcess
    -> 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 (Callable
-> [String]
-> ContT
     (ExitCode, [String], [String], [(String, Maybe [String])])
     IO
     CreateProcess
forall a. Callable -> [String] -> ContT a IO CreateProcess
withCallableToProcess Callable
bios [String]
fps) ((CreateProcess
  -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> (CreateProcess
    -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ \CreateProcess
bios' ->
      [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
Process.readProcessWithOutputs [String
hie_bios_output, String
hie_bios_deps] LogAction IO (WithSeverity Log)
l String
wdir CreateProcess
bios'

  [String]
deps <- case Maybe [String]
mb_deps of
    Just [String]
x  -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x
    Maybe [String]
Nothing -> LogAction IO (WithSeverity Log)
-> String -> Maybe Callable -> String -> LoadStyle -> IO [String]
biosDepsAction LogAction IO (WithSeverity Log)
l String
wdir Maybe Callable
bios_deps String
fp LoadStyle
loadStyle
        -- 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 a. a -> IO a
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] -> [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 [String
fp]

withCallableToProcess :: Callable -> [String] -> ContT a IO CreateProcess
withCallableToProcess :: forall a. Callable -> [String] -> ContT a IO CreateProcess
withCallableToProcess (Command String
shellCommand) [String]
files = ((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess)
-> ((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess
forall a b. (a -> b) -> a -> b
$ \CreateProcess -> IO a
action -> do
  [(String, String)]
old_env <- IO [(String, String)]
getEnvironment
  case [String]
files of
    [] -> CreateProcess -> IO a
action (CreateProcess -> IO a) -> CreateProcess -> IO a
forall a b. (a -> b) -> a -> b
$ (String -> CreateProcess
shell String
shellCommand) {env = Nothing}
    (String
x : [String]
_) ->
      ContT a IO String -> (String -> IO a) -> IO a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT ([String] -> ContT a IO String
forall a. [String] -> ContT a IO String
withHieBiosMultiArg [String]
files) ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
multi_file -> do
        let updated_env :: Maybe [(String, String)]
updated_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
hie_bios_multi_arg, String
multi_file)
              , (String
hie_bios_arg, String
x)
              ] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
              [(String, String)]
old_env
        CreateProcess -> IO a
action (CreateProcess -> IO a) -> CreateProcess -> IO a
forall a b. (a -> b) -> a -> b
$ (String -> CreateProcess
shell String
shellCommand){env = updated_env}
withCallableToProcess (Program String
path) [String]
files = ((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess)
-> ((CreateProcess -> IO a) -> IO a) -> ContT a IO CreateProcess
forall a b. (a -> b) -> a -> b
$ \CreateProcess -> IO a
action -> do
  String
canon_path <- String -> IO String
canonicalizePath String
path
  [(String, String)]
old_env <- IO [(String, String)]
getEnvironment
  case [String]
files of
    [] -> CreateProcess -> IO a
action (CreateProcess -> IO a) -> CreateProcess -> IO a
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
canon_path []){env = Nothing}
    (String
x : [String]
_) ->
      ContT a IO String -> (String -> IO a) -> IO a
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT ([String] -> ContT a IO String
forall a. [String] -> ContT a IO String
withHieBiosMultiArg [String]
files) ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
multi_file -> do
        let updated_env :: Maybe [(String, String)]
updated_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
hie_bios_multi_arg, String
multi_file) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
old_env
        CreateProcess -> IO a
action (CreateProcess -> IO a) -> CreateProcess -> IO a
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
canon_path [String
x]){env = updated_env}

withHieBiosMultiArg :: [String] -> ContT a IO FilePath
withHieBiosMultiArg :: forall a. [String] -> ContT a IO String
withHieBiosMultiArg [String]
files = ((String -> IO a) -> IO a) -> ContT a IO String
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((String -> IO a) -> IO a) -> ContT a IO String)
-> ((String -> IO a) -> IO a) -> ContT a IO String
forall a b. (a -> b) -> a -> b
$ \String -> IO a
action -> do
  String -> (String -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
hie_bios_multi_arg ((String -> Handle -> IO a) -> IO a)
-> (String -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
file Handle
h -> do
    case [String]
files of
      [] -> Handle -> IO ()
hClose Handle
h IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO a
action String
file
      (String
f0 : [String]
rest) -> do
        Handle -> String -> IO ()
hPutStr Handle
h String
f0
        [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
rest ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
f -> Handle -> String -> IO ()
hPutStr Handle
h String
"\x00" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> String -> IO ()
hPutStr Handle
h String
f
        Handle -> IO ()
hClose Handle
h
        String -> IO a
action String
file

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

-- |Cabal Cradle
-- Works for new-build by invoking `v2-repl`.
cabalCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a
cabalCradle :: forall b a.
LogAction IO (WithSeverity Log)
-> ResolvedCradles b
-> String
-> Maybe String
-> CradleProjectConfig
-> CradleAction a
cabalCradle LogAction IO (WithSeverity Log)
l ResolvedCradles b
cs String
wdir Maybe String
mc CradleProjectConfig
projectFile
  = CradleAction
    { actionName :: ActionName a
actionName = ActionName a
forall {a}. ActionName a
Types.Cabal
    , runCradle :: String -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
runCradle = \String
fp -> CradleLoadResultT IO ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> (LoadStyle -> CradleLoadResultT IO ComponentOptions)
-> LoadStyle
-> IO (CradleLoadResult ComponentOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedCradles b
-> String
-> Maybe String
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> String
-> LoadStyle
-> CradleLoadResultT IO ComponentOptions
forall a.
ResolvedCradles a
-> String
-> Maybe String
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> String
-> LoadStyle
-> CradleLoadResultT IO ComponentOptions
cabalAction ResolvedCradles b
cs String
wdir Maybe String
mc LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile String
fp
    , runGhcCmd :: [String] -> IO (CradleLoadResult String)
runGhcCmd = ResolvedCradles b
-> String
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [String]
-> IO (CradleLoadResult String)
forall a.
ResolvedCradles a
-> String
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [String]
-> IO (CradleLoadResult String)
runCabalGhcCmd ResolvedCradles b
cs String
wdir LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile
    }

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

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

stackYamlProcessArgs :: CradleProjectConfig -> [String]
stackYamlProcessArgs :: CradleProjectConfig -> [String]
stackYamlProcessArgs (ExplicitConfig String
yaml) = [String
"--stack-yaml", String
yaml]
stackYamlProcessArgs CradleProjectConfig
NoExplicitConfig = []

stackYamlLocationOrDefault :: CradleProjectConfig -> FilePath
stackYamlLocationOrDefault :: CradleProjectConfig -> String
stackYamlLocationOrDefault CradleProjectConfig
NoExplicitConfig = String
"stack.yaml"
stackYamlLocationOrDefault (ExplicitConfig String
yaml) = String
yaml

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

stackAction
  :: FilePath
  -> Maybe String
  -> CradleProjectConfig
  -> LogAction IO (WithSeverity Log)
  -> FilePath
  -> LoadStyle
  -> IO (CradleLoadResult ComponentOptions)
stackAction :: String
-> Maybe String
-> CradleProjectConfig
-> LogAction IO (WithSeverity Log)
-> String
-> LoadStyle
-> IO (CradleLoadResult ComponentOptions)
stackAction String
workDir Maybe String
mc CradleProjectConfig
syaml LogAction IO (WithSeverity Log)
l String
fp LoadStyle
loadStyle = do
  LogAction IO (WithSeverity Log) -> LoadStyle -> Text -> IO ()
forall (m :: * -> *).
Applicative m =>
LogAction m (WithSeverity Log) -> LoadStyle -> Text -> m ()
logCradleHasNoSupportForLoadWithContext LogAction IO (WithSeverity Log)
l LoadStyle
loadStyle Text
"stack"
  let ghcProc :: [String] -> CreateProcess
ghcProc [String]
args = String -> [String] -> CreateProcess
proc String
"stack" (CradleProjectConfig -> [String]
stackYamlProcessArgs CradleProjectConfig
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)
  -- Same wrapper works as with cabal
  String
wrapper_fp <- LogAction IO (WithSeverity Log)
-> ([String] -> CreateProcess) -> String -> IO String
withGhcWrapperTool LogAction IO (WithSeverity Log)
l [String] -> CreateProcess
ghcProc String
workDir
  (ExitCode
ex1, [String]
_stdo, [String]
stde, [(String
_, Maybe [String]
maybeArgs)]) <-
    [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
Process.readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
workDir
      (CreateProcess
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [String] -> CreateProcess
stackProcess CradleProjectConfig
syaml
          ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$  [String
"repl", String
"--no-nix-pure", String
"--with-ghc", String
wrapper_fp]
          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ String
comp | Just String
comp <- [Maybe String
mc] ]

  (ExitCode
ex2, [String]
pkg_args, [String]
stdr, [(String, Maybe [String])]
_) <-
    [String]
-> LogAction IO (WithSeverity Log)
-> String
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
Process.readProcessWithOutputs [String
hie_bios_output] LogAction IO (WithSeverity Log)
l String
workDir
      (CreateProcess
 -> IO (ExitCode, [String], [String], [(String, Maybe [String])]))
-> CreateProcess
-> IO (ExitCode, [String], [String], [(String, Maybe [String])])
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [String] -> CreateProcess
stackProcess CradleProjectConfig
syaml [String
"path", String
"--ghc-package-path"]

  let split_pkgs :: [String]
split_pkgs = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
splitSearchPath [String]
pkg_args
      pkg_ghc_args :: [String]
pkg_ghc_args = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
p -> [String
"-package-db", String
p] ) [String]
split_pkgs
      args :: [String]
args = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
maybeArgs
  case [String] -> Maybe (String, [String])
processCabalWrapperArgs [String]
args of
      Maybe (String, [String])
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 -> CradleProjectConfig -> IO [String]
stackCradleDependencies String
workDir String
workDir CradleProjectConfig
syaml
        CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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] -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex1
                    ([ 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)
                    [String
fp]
                  )

      Just (String
componentDir, [String]
ghc_args) -> do
        [String]
deps <- String -> String -> CradleProjectConfig -> IO [String]
stackCradleDependencies String
workDir String
componentDir CradleProjectConfig
syaml
        CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
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] -> [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
                  [String
fp]

stackProcess :: CradleProjectConfig -> [String] -> CreateProcess
stackProcess :: CradleProjectConfig -> [String] -> CreateProcess
stackProcess CradleProjectConfig
syaml [String]
args = String -> [String] -> CreateProcess
proc String
"stack" ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [String]
stackYamlProcessArgs CradleProjectConfig
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 a b. (a -> b -> b) -> b -> [a] -> b
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 -> String -> MaybeT IO String
Process.findFileUpwards 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 workDir fp = do
  wrapper_fp <- writeSystemTempFile "wrapper" bazelCommand
  setFileMode wrapper_fp accessModes
  let rel_path = makeRelative workDir fp
  (ex, args, stde) <-
      readProcessWithOutputFile workDir wrapper_fp [rel_path] []
  let args'  = filter (/= '\'') args
  let args'' = filter (/= "\"$GHCI_LOCATION\"") (words args')
  deps <- rulesHaskellCradleDependencies workDir
  return $ makeCradleResult (ex, stde, args'') deps


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

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

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

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

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

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

-}

makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> [FilePath] -> CradleLoadResult ComponentOptions
makeCradleResult :: (ExitCode, [String], String, [String])
-> [String] -> [String] -> CradleLoadResult ComponentOptions
makeCradleResult (ExitCode
ex, [String]
err, String
componentDir, [String]
gopts) [String]
deps [String]
loadingFiles =
  case ExitCode
ex of
    ExitFailure Int
_ -> CradleError -> CradleLoadResult ComponentOptions
forall r. CradleError -> CradleLoadResult r
CradleFail ([String] -> ExitCode -> [String] -> [String] -> CradleError
CradleError [String]
deps ExitCode
ex [String]
err [String]
loadingFiles)
    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 :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath :: LogAction IO (WithSeverity Log)
-> String -> [String] -> IO (CradleLoadResult String)
runGhcCmdOnPath LogAction IO (WithSeverity Log)
l String
wdir [String]
args = LogAction IO (WithSeverity Log)
-> String
-> String
-> [String]
-> String
-> IO (CradleLoadResult String)
Process.readProcessWithCwd LogAction IO (WithSeverity Log)
l String
wdir String
"ghc" [String]
args String
""

-- | Log that the cradle has no supported for loading with context, if and only if
-- 'LoadWithContext' was requested.
logCradleHasNoSupportForLoadWithContext :: Applicative m => LogAction m (WithSeverity Log) -> LoadStyle -> T.Text -> m ()
logCradleHasNoSupportForLoadWithContext :: forall (m :: * -> *).
Applicative m =>
LogAction m (WithSeverity Log) -> LoadStyle -> Text -> m ()
logCradleHasNoSupportForLoadWithContext LogAction m (WithSeverity Log)
l (LoadWithContext [String]
_) Text
crdlName =
  LogAction m (WithSeverity Log)
l LogAction m (WithSeverity Log) -> WithSeverity Log -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity
        (Text -> Maybe Text -> Log
LogLoadWithContextUnsupported Text
crdlName
          (Maybe Text -> Log) -> Maybe Text -> Log
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
crdlName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't support loading multiple components at once"
        )
        Severity
Info
logCradleHasNoSupportForLoadWithContext LogAction m (WithSeverity Log)
_ LoadStyle
_ Text
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()