{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | Types and function related to Stack's @exec@, @ghc@, @run@, @runghc@ and

-- @runhaskell@ commands.

module Stack.Exec
  ( ExecOpts (..)
  , SpecialExecCmd (..)
  , ExecOptsExtra (..)
  , execCmd
  ) where

import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Distribution.Types.PackageName ( unPackageName )
import           RIO.NonEmpty ( head, nonEmpty )
import           RIO.Process ( exec )
import           Stack.Build ( build )
import           Stack.Build.Target
                   ( NeedTargets (..), RawTarget (..), parseRawTarget )
import           Stack.GhcPkg ( findGhcPkgField )
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..), getGhcPkgExe )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.NamedComponent ( NamedComponent (..), isCExe )
import           Stack.Types.Runner ( Runner )
import           Stack.Types.SourceMap ( SMWanted (..), ppComponents )
import           System.Directory ( withCurrentDirectory )
import           System.FilePath ( isValid )

-- | Type representing exceptions thrown by functions in the "Stack.Exec"

-- module.

newtype ExecException
  = InvalidPathForExec FilePath
  deriving (Int -> ExecException -> ShowS
[ExecException] -> ShowS
ExecException -> String
(Int -> ExecException -> ShowS)
-> (ExecException -> String)
-> ([ExecException] -> ShowS)
-> Show ExecException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecException -> ShowS
showsPrec :: Int -> ExecException -> ShowS
$cshow :: ExecException -> String
show :: ExecException -> String
$cshowList :: [ExecException] -> ShowS
showList :: [ExecException] -> ShowS
Show, Typeable)

instance Exception ExecException where
  displayException :: ExecException -> String
displayException (InvalidPathForExec String
path) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-1541]\n"
    , String
"Got an invalid '--cwd' argument for 'stack exec' ("
    , String
path
    , String
")."
    ]

-- | Type representing \'pretty\' exceptions thrown by functions in the

-- "Stack.Exec" module.

data ExecPrettyException
  = PackageIdNotFoundBug !String
  | ExecutableToRunNotFound
  | NoPackageIdReportedBug
  | InvalidExecTargets ![Text]
  deriving (Int -> ExecPrettyException -> ShowS
[ExecPrettyException] -> ShowS
ExecPrettyException -> String
(Int -> ExecPrettyException -> ShowS)
-> (ExecPrettyException -> String)
-> ([ExecPrettyException] -> ShowS)
-> Show ExecPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecPrettyException -> ShowS
showsPrec :: Int -> ExecPrettyException -> ShowS
$cshow :: ExecPrettyException -> String
show :: ExecPrettyException -> String
$cshowList :: [ExecPrettyException] -> ShowS
showList :: [ExecPrettyException] -> ShowS
Show, Typeable)

instance Pretty ExecPrettyException where
  pretty :: ExecPrettyException -> StyleDoc
pretty (PackageIdNotFoundBug String
name) = String -> StyleDoc -> StyleDoc
bugPrettyReport String
"[S-8251]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> StyleDoc
fillSep
      [ String -> StyleDoc
flow String
"Could not find the package id of the package"
      , Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
  pretty ExecPrettyException
ExecutableToRunNotFound =
       StyleDoc
"[S-2483]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"No executables found."
  pretty ExecPrettyException
NoPackageIdReportedBug = String -> StyleDoc -> StyleDoc
bugPrettyReport String
"S-8600" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
    String -> StyleDoc
flow String
"execCmd: findGhcPkgField returned Just \"\"."
  pretty (InvalidExecTargets [Text]
targets) =
       StyleDoc
"[S-7371]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"The following are invalid"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--package"
         , StyleDoc
"values for"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack ghc") StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack runghc") StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , StyleDoc
"or"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack runhaskell") StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((Text -> StyleDoc) -> [Text] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc) -> (Text -> StyleDoc) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
string (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
targets )

instance Exception ExecPrettyException

-- Type representing Stack's execution commands.

data SpecialExecCmd
  = ExecCmd String
  | ExecRun
  | ExecGhc
  | ExecRunGhc
  deriving (SpecialExecCmd -> SpecialExecCmd -> Bool
(SpecialExecCmd -> SpecialExecCmd -> Bool)
-> (SpecialExecCmd -> SpecialExecCmd -> Bool) -> Eq SpecialExecCmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpecialExecCmd -> SpecialExecCmd -> Bool
== :: SpecialExecCmd -> SpecialExecCmd -> Bool
$c/= :: SpecialExecCmd -> SpecialExecCmd -> Bool
/= :: SpecialExecCmd -> SpecialExecCmd -> Bool
Eq, Int -> SpecialExecCmd -> ShowS
[SpecialExecCmd] -> ShowS
SpecialExecCmd -> String
(Int -> SpecialExecCmd -> ShowS)
-> (SpecialExecCmd -> String)
-> ([SpecialExecCmd] -> ShowS)
-> Show SpecialExecCmd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpecialExecCmd -> ShowS
showsPrec :: Int -> SpecialExecCmd -> ShowS
$cshow :: SpecialExecCmd -> String
show :: SpecialExecCmd -> String
$cshowList :: [SpecialExecCmd] -> ShowS
showList :: [SpecialExecCmd] -> ShowS
Show)

data ExecOptsExtra = ExecOptsExtra
  { ExecOptsExtra -> EnvSettings
envSettings :: !EnvSettings
  , ExecOptsExtra -> [String]
packages :: ![String]
  , ExecOptsExtra -> [String]
rtsOptions :: ![String]
  , ExecOptsExtra -> Maybe String
cwd :: !(Maybe FilePath)
  }
  deriving Int -> ExecOptsExtra -> ShowS
[ExecOptsExtra] -> ShowS
ExecOptsExtra -> String
(Int -> ExecOptsExtra -> ShowS)
-> (ExecOptsExtra -> String)
-> ([ExecOptsExtra] -> ShowS)
-> Show ExecOptsExtra
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecOptsExtra -> ShowS
showsPrec :: Int -> ExecOptsExtra -> ShowS
$cshow :: ExecOptsExtra -> String
show :: ExecOptsExtra -> String
$cshowList :: [ExecOptsExtra] -> ShowS
showList :: [ExecOptsExtra] -> ShowS
Show

-- Type representing options for Stack's execution commands.

data ExecOpts = ExecOpts
  { ExecOpts -> SpecialExecCmd
cmd :: !SpecialExecCmd
  , ExecOpts -> [String]
args :: ![String]
  , ExecOpts -> ExecOptsExtra
extra :: !ExecOptsExtra
  }
  deriving Int -> ExecOpts -> ShowS
[ExecOpts] -> ShowS
ExecOpts -> String
(Int -> ExecOpts -> ShowS)
-> (ExecOpts -> String) -> ([ExecOpts] -> ShowS) -> Show ExecOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecOpts -> ShowS
showsPrec :: Int -> ExecOpts -> ShowS
$cshow :: ExecOpts -> String
show :: ExecOpts -> String
$cshowList :: [ExecOpts] -> ShowS
showList :: [ExecOpts] -> ShowS
Show

-- Type representing valid targets for --package option.

data ExecTarget = ExecTarget PackageName (Maybe Version)

-- | The function underlying Stack's @exec@, @ghc@, @run@, @runghc@ and

-- @runhaskell@ commands. Execute a command.

execCmd :: ExecOpts -> RIO Runner ()
execCmd :: ExecOpts -> RIO Runner ()
execCmd ExecOpts
opts =
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
    let ([Text]
errs, [ExecTarget]
execTargets) = [Either Text ExecTarget] -> ([Text], [ExecTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text ExecTarget] -> ([Text], [ExecTarget]))
-> [Either Text ExecTarget] -> ([Text], [ExecTarget])
forall a b. (a -> b) -> a -> b
$ (Text -> Either Text ExecTarget)
-> [Text] -> [Either Text ExecTarget]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Either Text ExecTarget
fromTarget [Text]
targets
    Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ ExecPrettyException -> RIO EnvConfig ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (ExecPrettyException -> RIO EnvConfig ())
-> ExecPrettyException -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ [Text] -> ExecPrettyException
InvalidExecTargets [Text]
errs
    Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ExecTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExecTarget]
execTargets) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing

    Config
config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
    ProcessContext
menv <- IO ProcessContext -> RIO EnvConfig ProcessContext
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO EnvConfig ProcessContext)
-> IO ProcessContext -> RIO EnvConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ Config
config.processContextSettings ExecOptsExtra
eo.envSettings
    ProcessContext -> RIO EnvConfig () -> RIO EnvConfig ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ do
      -- Add RTS options to arguments

      let argsWithRts :: [String] -> [String]
argsWithRts [String]
args = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ExecOptsExtra
eo.rtsOptions
                  then [String]
args :: [String]
                  else [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+RTS"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ExecOptsExtra
eo.rtsOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-RTS"]
      (String
cmd, [String]
args) <- case (ExecOpts
opts.cmd, [String] -> [String]
argsWithRts ExecOpts
opts.args) of
        (ExecCmd String
cmd, [String]
args) -> (String, [String]) -> RIO EnvConfig (String, [String])
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
cmd, [String]
args)
        (SpecialExecCmd
ExecRun, [String]
args) -> [String] -> RIO EnvConfig (String, [String])
forall {s}. HasEnvConfig s => [String] -> RIO s (String, [String])
getRunCmd [String]
args
        (SpecialExecCmd
ExecGhc, [String]
args) -> [ExecTarget] -> [String] -> RIO EnvConfig (String, [String])
forall {s}.
(HasCompiler s, HasProcessContext s, HasTerm s) =>
[ExecTarget] -> [String] -> RIO s (String, [String])
getGhcCmd [ExecTarget]
execTargets [String]
args
        (SpecialExecCmd
ExecRunGhc, [String]
args) -> [ExecTarget] -> [String] -> RIO EnvConfig (String, [String])
forall {s}.
(HasCompiler s, HasProcessContext s, HasTerm s) =>
[ExecTarget] -> [String] -> RIO s (String, [String])
getRunGhcCmd [ExecTarget]
execTargets [String]
args

      Maybe String -> RIO EnvConfig () -> RIO EnvConfig ()
runWithPath ExecOptsExtra
eo.cwd (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO EnvConfig ()
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec String
cmd [String]
args
 where
  eo :: ExecOptsExtra
eo = ExecOpts
opts.extra

  targets :: [Text]
targets = (String -> [Text]) -> [String] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> [Text]
T.words (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) ExecOptsExtra
eo.packages
  boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI { targetsCLI = targets }

  fromTarget :: Text -> Either Text ExecTarget
  fromTarget :: Text -> Either Text ExecTarget
fromTarget Text
target =
    case Text -> Maybe RawTarget
parseRawTarget Text
target Maybe RawTarget
-> (RawTarget -> Maybe ExecTarget) -> Maybe ExecTarget
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawTarget -> Maybe ExecTarget
toExecTarget of
      Maybe ExecTarget
Nothing -> Text -> Either Text ExecTarget
forall a b. a -> Either a b
Left Text
target
      Just ExecTarget
execTarget -> ExecTarget -> Either Text ExecTarget
forall a b. b -> Either a b
Right ExecTarget
execTarget

  toExecTarget :: RawTarget -> Maybe ExecTarget
  toExecTarget :: RawTarget -> Maybe ExecTarget
toExecTarget (RTPackageComponent PackageName
_ UnresolvedComponent
_) = Maybe ExecTarget
forall a. Maybe a
Nothing
  toExecTarget (RTComponent Text
_) = Maybe ExecTarget
forall a. Maybe a
Nothing
  toExecTarget (RTPackage PackageName
name) = ExecTarget -> Maybe ExecTarget
forall a. a -> Maybe a
Just (ExecTarget -> Maybe ExecTarget) -> ExecTarget -> Maybe ExecTarget
forall a b. (a -> b) -> a -> b
$ PackageName -> Maybe Version -> ExecTarget
ExecTarget PackageName
name Maybe Version
forall a. Maybe a
Nothing
  toExecTarget (RTPackageIdentifier (PackageIdentifier PackageName
name Version
pkgId)) =
    ExecTarget -> Maybe ExecTarget
forall a. a -> Maybe a
Just (ExecTarget -> Maybe ExecTarget) -> ExecTarget -> Maybe ExecTarget
forall a b. (a -> b) -> a -> b
$ PackageName -> Maybe Version -> ExecTarget
ExecTarget PackageName
name (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
pkgId)

  -- return the package-id of the first package in GHC_PACKAGE_PATH

  getPkgId :: ExecTarget -> RIO env String
getPkgId (ExecTarget PackageName
pkgName Maybe Version
_) = do
    let name :: String
name = PackageName -> String
unPackageName PackageName
pkgName
    GhcPkgExe
pkg <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
    Maybe Text
mId <- GhcPkgExe
-> [Path Abs Dir] -> String -> Text -> RIO env (Maybe Text)
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> String -> Text -> RIO env (Maybe Text)
findGhcPkgField GhcPkgExe
pkg [] String
name Text
"id"
    case Maybe Text
mId of
      Just Text
i -> RIO env String
-> (NonEmpty String -> RIO env String)
-> Maybe (NonEmpty String)
-> RIO env String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (ExecPrettyException -> RIO env String
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO ExecPrettyException
NoPackageIdReportedBug)
        (String -> RIO env String
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> RIO env String)
-> (NonEmpty String -> String) -> NonEmpty String -> RIO env String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> String
forall a. NonEmpty a -> a
head)
        ([String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([String] -> Maybe (NonEmpty String))
-> [String] -> Maybe (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
i)
      -- should never happen as we have already installed the packages

      Maybe Text
_      -> ExecPrettyException -> RIO env String
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (String -> ExecPrettyException
PackageIdNotFoundBug String
name)

  getPkgOpts :: [ExecTarget] -> RIO env [String]
getPkgOpts [ExecTarget]
pkgs =
    ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-package-id=" ++) ([String] -> [String]) -> RIO env [String] -> RIO env [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExecTarget -> RIO env String) -> [ExecTarget] -> RIO env [String]
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 ExecTarget -> RIO env String
forall {env}.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
ExecTarget -> RIO env String
getPkgId [ExecTarget]
pkgs

  getRunCmd :: [String] -> RIO s (String, [String])
getRunCmd [String]
args = do
    Map PackageName ProjectPackage
packages <- Getting
  (Map PackageName ProjectPackage) s (Map PackageName ProjectPackage)
-> RIO s (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage) s (Map PackageName ProjectPackage)
 -> RIO s (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage) s (Map PackageName ProjectPackage)
-> RIO s (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> s -> Const (Map PackageName ProjectPackage) s
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' s BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> s -> Const (Map PackageName ProjectPackage) s)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> BuildConfig
    -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage) s (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
    [Set NamedComponent]
pkgComponents <- [ProjectPackage]
-> (ProjectPackage -> RIO s (Set NamedComponent))
-> RIO s [Set NamedComponent]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems Map PackageName ProjectPackage
packages) ProjectPackage -> RIO s (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents
    let executables :: [NamedComponent]
executables = (Set NamedComponent -> [NamedComponent])
-> [Set NamedComponent] -> [NamedComponent]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((NamedComponent -> Bool) -> [NamedComponent] -> [NamedComponent]
forall a. (a -> Bool) -> [a] -> [a]
filter NamedComponent -> Bool
isCExe ([NamedComponent] -> [NamedComponent])
-> (Set NamedComponent -> [NamedComponent])
-> Set NamedComponent
-> [NamedComponent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList) [Set NamedComponent]
pkgComponents
    let (Maybe NamedComponent
exe, [String]
args') = case [String]
args of
          [] -> (Maybe NamedComponent
firstExe, [String]
args)
          String
x:[String]
xs -> case (NamedComponent -> Bool)
-> [NamedComponent] -> Maybe NamedComponent
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\NamedComponent
y -> NamedComponent
y NamedComponent -> NamedComponent -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> NamedComponent
CExe (String -> Text
T.pack String
x)) [NamedComponent]
executables of
            Maybe NamedComponent
Nothing -> (Maybe NamedComponent
firstExe, [String]
args)
            Maybe NamedComponent
argExe -> (Maybe NamedComponent
argExe, [String]
xs)
         where
          firstExe :: Maybe NamedComponent
firstExe = [NamedComponent] -> Maybe NamedComponent
forall a. [a] -> Maybe a
listToMaybe [NamedComponent]
executables
    case Maybe NamedComponent
exe of
      Just (CExe Text
exe') -> do
        [Text] -> RIO s () -> RIO s ()
forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets [Char -> Text -> Text
T.cons Char
':' Text
exe'] (RIO s () -> RIO s ()) -> RIO s () -> RIO s ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO s ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing
        (String, [String]) -> RIO s (String, [String])
forall a. a -> RIO s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
T.unpack Text
exe', [String]
args')
      Maybe NamedComponent
_ -> ExecPrettyException -> RIO s (String, [String])
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO ExecPrettyException
ExecutableToRunNotFound

  getGhcCmd :: [ExecTarget] -> [String] -> RIO s (String, [String])
getGhcCmd [ExecTarget]
pkgs [String]
args = do
    [String]
pkgopts <- [ExecTarget] -> RIO s [String]
forall {env}.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[ExecTarget] -> RIO env [String]
getPkgOpts [ExecTarget]
pkgs
    Path Abs File
compiler <- Getting (Path Abs File) s (Path Abs File) -> RIO s (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs File) s (Path Abs File)
 -> RIO s (Path Abs File))
-> Getting (Path Abs File) s (Path Abs File)
-> RIO s (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Getting (Path Abs File) s CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter s CompilerPaths
compilerPathsL Getting (Path Abs File) s CompilerPaths
-> ((Path Abs File -> Const (Path Abs File) (Path Abs File))
    -> CompilerPaths -> Const (Path Abs File) CompilerPaths)
-> Getting (Path Abs File) s (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.compiler)
    (String, [String]) -> RIO s (String, [String])
forall a. a -> RIO s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
compiler, [String]
pkgopts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args)

  getRunGhcCmd :: [ExecTarget] -> [String] -> RIO s (String, [String])
getRunGhcCmd [ExecTarget]
pkgs [String]
args = do
    [String]
pkgopts <- [ExecTarget] -> RIO s [String]
forall {env}.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[ExecTarget] -> RIO env [String]
getPkgOpts [ExecTarget]
pkgs
    Path Abs File
interpret <- Getting (Path Abs File) s (Path Abs File) -> RIO s (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs File) s (Path Abs File)
 -> RIO s (Path Abs File))
-> Getting (Path Abs File) s (Path Abs File)
-> RIO s (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Getting (Path Abs File) s CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter s CompilerPaths
compilerPathsL Getting (Path Abs File) s CompilerPaths
-> ((Path Abs File -> Const (Path Abs File) (Path Abs File))
    -> CompilerPaths -> Const (Path Abs File) CompilerPaths)
-> Getting (Path Abs File) s (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.interpreter)
    (String, [String]) -> RIO s (String, [String])
forall a. a -> RIO s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
interpret, [String]
pkgopts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args)

  runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()
  runWithPath :: Maybe String -> RIO EnvConfig () -> RIO EnvConfig ()
runWithPath Maybe String
path RIO EnvConfig ()
callback = case Maybe String
path of
    Maybe String
Nothing -> RIO EnvConfig ()
callback
    Just String
p | Bool -> Bool
not (String -> Bool
isValid String
p) -> ExecException -> RIO EnvConfig ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ExecException -> RIO EnvConfig ())
-> ExecException -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ String -> ExecException
InvalidPathForExec String
p
    Just String
p -> (UnliftIO (RIO EnvConfig) -> IO ()) -> RIO EnvConfig ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO (RIO EnvConfig) -> IO ()) -> RIO EnvConfig ())
-> (UnliftIO (RIO EnvConfig) -> IO ()) -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ \UnliftIO (RIO EnvConfig)
ul -> String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
p (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (RIO EnvConfig) -> forall a. RIO EnvConfig a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO EnvConfig)
ul RIO EnvConfig ()
callback