{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
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 )
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
")."
]
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
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 -> 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
data ExecOpts = ExecOpts
{ ExecOpts -> SpecialExecCmd
cmd :: !SpecialExecCmd
, ExecOpts -> [String]
args :: ![String]
, :: !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
data ExecTarget = ExecTarget PackageName (Maybe Version)
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
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)
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)
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