{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}

-- | Run a GHCi configured with the user's package(s).

module Stack.Ghci
    ( GhciOpts(..)
    , GhciPkgInfo(..)
    , GhciException(..)
    , ghci
    ) where

import           Stack.Prelude hiding (Display (..))
import           Control.Monad.State.Strict (State, execState, get, modify)
import           Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import           Data.List
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Distribution.PackageDescription as C
import           Path
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO hiding (withSystemTempDir)
import qualified RIO
import           RIO.PrettyPrint
import           RIO.Process (HasProcessContext, exec, proc, readProcess_)
import           Stack.Build
import           Stack.Build.Installed
import           Stack.Build.Source
import           Stack.Build.Target
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Ghci.Script
import           Stack.Package
import           Stack.Setup (withNewLocalBuildTargets)
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           System.IO (putStrLn)
import           System.IO.Temp (getCanonicalTemporaryDirectory)
import           System.Permissions (setScriptPerms)

-- | Command-line options for GHC.
data GhciOpts = GhciOpts
    { GhciOpts -> [Text]
ghciTargets            :: ![Text]
    , GhciOpts -> [String]
ghciArgs               :: ![String]
    , GhciOpts -> [String]
ghciGhcOptions         :: ![String]
    , GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags              :: !(Map ApplyCLIFlag (Map FlagName Bool))
    , GhciOpts -> Maybe String
ghciGhcCommand         :: !(Maybe FilePath)
    , GhciOpts -> Bool
ghciNoLoadModules      :: !Bool
    , GhciOpts -> [String]
ghciAdditionalPackages :: ![String]
    , GhciOpts -> Maybe Text
ghciMainIs             :: !(Maybe Text)
    , GhciOpts -> Bool
ghciLoadLocalDeps      :: !Bool
    , GhciOpts -> Bool
ghciSkipIntermediate   :: !Bool
    , GhciOpts -> Maybe Bool
ghciHidePackages       :: !(Maybe Bool)
    , GhciOpts -> Bool
ghciNoBuild            :: !Bool
    , GhciOpts -> Bool
ghciOnlyMain           :: !Bool
    } deriving Int -> GhciOpts -> ShowS
[GhciOpts] -> ShowS
GhciOpts -> String
(Int -> GhciOpts -> ShowS)
-> (GhciOpts -> String) -> ([GhciOpts] -> ShowS) -> Show GhciOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciOpts] -> ShowS
$cshowList :: [GhciOpts] -> ShowS
show :: GhciOpts -> String
$cshow :: GhciOpts -> String
showsPrec :: Int -> GhciOpts -> ShowS
$cshowsPrec :: Int -> GhciOpts -> ShowS
Show

-- | Necessary information to load a package or its components.
--
-- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order
-- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786
data GhciPkgInfo = GhciPkgInfo
    { GhciPkgInfo -> PackageName
ghciPkgName :: !PackageName
    , GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]
    , GhciPkgInfo -> Path Abs Dir
ghciPkgDir :: !(Path Abs Dir)
    , GhciPkgInfo -> ModuleMap
ghciPkgModules :: !ModuleMap
    , GhciPkgInfo -> [Path Abs File]
ghciPkgCFiles :: ![Path Abs File] -- ^ C files.
    , GhciPkgInfo -> Map NamedComponent [Path Abs File]
ghciPkgMainIs :: !(Map NamedComponent [Path Abs File])
    , GhciPkgInfo -> Maybe [Path Abs File]
ghciPkgTargetFiles :: !(Maybe [Path Abs File])
    , GhciPkgInfo -> Package
ghciPkgPackage :: !Package
    } deriving Int -> GhciPkgInfo -> ShowS
[GhciPkgInfo] -> ShowS
GhciPkgInfo -> String
(Int -> GhciPkgInfo -> ShowS)
-> (GhciPkgInfo -> String)
-> ([GhciPkgInfo] -> ShowS)
-> Show GhciPkgInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciPkgInfo] -> ShowS
$cshowList :: [GhciPkgInfo] -> ShowS
show :: GhciPkgInfo -> String
$cshow :: GhciPkgInfo -> String
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
Show

-- | Loaded package description and related info.
data GhciPkgDesc = GhciPkgDesc
    { GhciPkgDesc -> Package
ghciDescPkg :: !Package
    , GhciPkgDesc -> Path Abs File
ghciDescCabalFp :: !(Path Abs File)
    , GhciPkgDesc -> Target
ghciDescTarget :: !Target
    }

-- Mapping from a module name to a map with all of the paths that use
-- that name. Each of those paths is associated with a set of components
-- that contain it. Purpose of this complex structure is for use in
-- 'checkForDuplicateModules'.
type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent)))

unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps = (Map (Path Abs File) (Set (PackageName, NamedComponent))
 -> Map (Path Abs File) (Set (PackageName, NamedComponent))
 -> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> [ModuleMap] -> ModuleMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith ((Set (PackageName, NamedComponent)
 -> Set (PackageName, NamedComponent)
 -> Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent)
forall a. Ord a => Set a -> Set a -> Set a
S.union)

data GhciException
    = InvalidPackageOption String
    | LoadingDuplicateModules
    | MissingFileTarget String
    | Can'tSpecifyFilesAndTargets
    | Can'tSpecifyFilesAndMainIs
    | GhciTargetParseException [Text]
    deriving (Typeable)

instance Exception GhciException

instance Show GhciException where
    show :: GhciException -> String
show (InvalidPackageOption String
name) =
        String
"Failed to parse --package option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
    show GhciException
LoadingDuplicateModules = [String] -> String
unlines
        [ String
"Not attempting to start ghci due to these duplicate modules."
        , String
"Use --no-load to try to start it anyway, without loading any modules (but these are still likely to cause errors)"
        ]
    show (MissingFileTarget String
name) =
        String
"Cannot find file target " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
    show GhciException
Can'tSpecifyFilesAndTargets =
        String
"Cannot use 'stack ghci' with both file targets and package targets"
    show GhciException
Can'tSpecifyFilesAndMainIs =
        String
"Cannot use 'stack ghci' with both file targets and --main-is flag"
    show (GhciTargetParseException [Text]
xs) =
        StackBuildException -> String
forall a. Show a => a -> String
show ([Text] -> StackBuildException
TargetParseException [Text]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
"\nNote that to specify options to be passed to GHCi, use the --ghci-options flag"

-- | Launch a GHCi session for the given local package targets with the
-- given options and configure it with the load paths and extensions
-- of those targets.
ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci :: GhciOpts -> RIO env ()
ghci opts :: GhciOpts
opts@GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} = do
    let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
            { boptsCLITargets :: [Text]
boptsCLITargets = []
            , boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags
            }
    SourceMap
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL((EnvConfig -> Const SourceMap EnvConfig)
 -> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
    -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    [LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    [LocalPackage]
depLocals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
    let localMap :: Map PackageName LocalPackage
localMap =
          [(PackageName, LocalPackage)] -> Map PackageName LocalPackage
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Package -> PackageName
packageName (Package -> PackageName) -> Package -> PackageName
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals [LocalPackage] -> [LocalPackage] -> [LocalPackage]
forall a. [a] -> [a] -> [a]
++ [LocalPackage]
depLocals]
        -- FIXME:qrilka this looks wrong to go back to SMActual
        sma :: SMActual GlobalPackage
sma = SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
SMActual
             { smaCompiler :: ActualCompiler
smaCompiler = SourceMap -> ActualCompiler
smCompiler SourceMap
sourceMap
             , smaProject :: Map PackageName ProjectPackage
smaProject = SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap
             , smaDeps :: Map PackageName DepPackage
smaDeps = SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap
             , smaGlobal :: Map PackageName GlobalPackage
smaGlobal = SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap
             }
    -- Parse --main-is argument.
    Maybe (Map PackageName Target)
mainIsTargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
ghciMainIs
    -- Parse to either file targets or build targets
    Either [Path Abs File] (Map PackageName Target)
etargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
ghciTargets
    (Map PackageName Target
inputTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) <- case Either [Path Abs File] (Map PackageName Target)
etargets of
        Right Map PackageName Target
packageTargets -> (Map PackageName Target,
 Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
     env
     (Map PackageName Target,
      Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName Target
packageTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. Maybe a
Nothing)
        Left [Path Abs File]
rawFileTargets -> do
            case Maybe (Map PackageName Target)
mainIsTargets of
                Maybe (Map PackageName Target)
Nothing -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Map PackageName Target
_ -> GhciException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndMainIs
            -- Figure out targets based on filepath targets
            (Map PackageName Target
targetMap, Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles) <- [LocalPackage]
-> [Path Abs File]
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
rawFileTargets
            (Map PackageName Target,
 Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
     env
     (Map PackageName Target,
      Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName Target
targetMap, (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. a -> Maybe a
Just (Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles))
    -- Get a list of all the local target packages.
    [(PackageName, (Path Abs File, Target))]
localTargets <- GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
opts Map PackageName Target
inputTargets Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap
    -- Get a list of all the non-local target packages.
    [PackageName]
nonLocalTargets <- Map PackageName Target -> RIO env [PackageName]
forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
    -- Check if additional package arguments are sensible.
    [PackageName]
addPkgs <- [String] -> RIO env [PackageName]
forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
ghciAdditionalPackages
    -- Load package descriptions.
    [GhciPkgDesc]
pkgDescs <- BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets
    -- If necessary, ask user about which main module to load.
    BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
    Maybe (Path Abs File)
mainFile <-
        if Bool
ghciNoLoadModules
            then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing
            else do
              -- Figure out package files, in order to ask the user
              -- about which main module to load. See the note below for
              -- why this is done again after the build. This could
              -- potentially be done more efficiently, because all we
              -- need is the location of main modules, not the rest.
              [GhciPkgInfo]
pkgs0 <- InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (((Map PackageName [Path Abs File], [Path Abs File])
 -> Map PackageName [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File]
forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
              BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
forall env.
HasRunner env =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
localTargets [GhciPkgInfo]
pkgs0
    let pkgTargets :: PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
targets =
          case Target
targets of
            TargetAll PackageType
_  -> [String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pn)]
            TargetComps Set NamedComponent
comps -> [(PackageName, NamedComponent) -> Text
renderPkgComponent (PackageName
pn, NamedComponent
c) | NamedComponent
c <- Set NamedComponent -> [NamedComponent]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps]
    -- Build required dependencies and setup local packages.
    GhciOpts -> [Text] -> RIO env ()
forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
opts ([Text] -> RIO env ()) -> [Text] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      ((PackageName, (Path Abs File, Target)) -> [Text])
-> [(PackageName, (Path Abs File, Target))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
pn, (Path Abs File
_, Target
t)) -> PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
t) [(PackageName, (Path Abs File, Target))]
localTargets
    [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets
    -- Load the list of modules _after_ building, to catch changes in
    -- unlisted dependencies (#1180)
    [GhciPkgInfo]
pkgs <- InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (((Map PackageName [Path Abs File], [Path Abs File])
 -> Map PackageName [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File]
forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
    [GhciPkgInfo] -> RIO env ()
forall env. HasLogFunc env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs
    -- Finally, do the invocation of ghci
    GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci GhciOpts
opts [(PackageName, (Path Abs File, Target))]
localTargets Maybe (Path Abs File)
mainFile [GhciPkgInfo]
pkgs ([Path Abs File]
-> ((Map PackageName [Path Abs File], [Path Abs File])
    -> [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall a b. (a, b) -> b
snd Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) ([PackageName]
nonLocalTargets [PackageName] -> [PackageName] -> [PackageName]
forall a. [a] -> [a] -> [a]
++ [PackageName]
addPkgs)

preprocessTargets
    :: HasEnvConfig env
    => BuildOptsCLI
    -> SMActual GlobalPackage
    -> [Text]
    -> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets :: BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
rawTargets = do
    let ([Text]
fileTargetsRaw, [Text]
normalTargetsRaw) =
            (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\Text
t -> Text
".hs" Text -> Text -> Bool
`T.isSuffixOf` Text
t Bool -> Bool -> Bool
|| Text
".lhs" Text -> Text -> Bool
`T.isSuffixOf` Text
t)
                      [Text]
rawTargets
    -- Only use file targets if we have no normal targets.
    if Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
normalTargetsRaw
        then do
            [Path Abs File]
fileTargets <- [Text]
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fileTargetsRaw ((Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File])
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ \Text
fp0 -> do
                let fp :: String
fp = Text -> String
T.unpack Text
fp0
                Maybe (Path Abs File)
mpath <- IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File)))
-> IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ IO (Path Abs File) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (String -> IO (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp)
                case Maybe (Path Abs File)
mpath of
                    Maybe (Path Abs File)
Nothing -> GhciException -> RIO env (Path Abs File)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> GhciException
MissingFileTarget String
fp)
                    Just Path Abs File
path -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
path
            Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Path Abs File] -> Either [Path Abs File] (Map PackageName Target)
forall a b. a -> Either a b
Left [Path Abs File]
fileTargets)
        else do
            -- Try parsing targets before checking if both file and
            -- module targets are specified (see issue#3342).
            let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text]
normalTargetsRaw }
            SMTargets
normalTargets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
                RIO env SMTargets
-> (StackBuildException -> RIO env SMTargets) -> RIO env SMTargets
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \StackBuildException
ex -> case StackBuildException
ex of
                    TargetParseException [Text]
xs -> GhciException -> RIO env SMTargets
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Text] -> GhciException
GhciTargetParseException [Text]
xs)
                    StackBuildException
_ -> StackBuildException -> RIO env SMTargets
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM StackBuildException
ex
            Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ GhciException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
            Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName Target
-> Either [Path Abs File] (Map PackageName Target)
forall a b. b -> Either a b
Right (Map PackageName Target
 -> Either [Path Abs File] (Map PackageName Target))
-> Map PackageName Target
-> Either [Path Abs File] (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ SMTargets -> Map PackageName Target
smtTargets SMTargets
normalTargets)

parseMainIsTargets
     :: HasEnvConfig env
     => BuildOptsCLI
     -> SMActual GlobalPackage
     -> Maybe Text
     -> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets :: BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
mtarget = Maybe Text
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Text
mtarget ((Text -> RIO env (Map PackageName Target))
 -> RIO env (Maybe (Map PackageName Target)))
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall a b. (a -> b) -> a -> b
$ \Text
target -> do
     let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text
target] }
     SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
     Map PackageName Target -> RIO env (Map PackageName Target)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName Target -> RIO env (Map PackageName Target))
-> Map PackageName Target -> RIO env (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ SMTargets -> Map PackageName Target
smtTargets SMTargets
targets

-- | Display PackageName + NamedComponent
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent = Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (StyleDoc -> StyleDoc)
-> ((PackageName, NamedComponent) -> StyleDoc)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, NamedComponent) -> String)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> ((PackageName, NamedComponent) -> Text)
-> (PackageName, NamedComponent)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent

findFileTargets
    :: HasEnvConfig env
    => [LocalPackage]
    -> [Path Abs File]
    -> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File])
findFileTargets :: [LocalPackage]
-> [Path Abs File]
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
fileTargets = do
    [(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages <- [LocalPackage]
-> (LocalPackage
    -> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
-> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
locals ((LocalPackage
  -> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
 -> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])])
-> (LocalPackage
    -> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
-> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])]
forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp -> do
        (Map NamedComponent (Map ModuleName (Path Abs File))
_,Map NamedComponent [DotCabalPath]
compFiles,Set (Path Abs File)
_,[PackageWarning]
_) <- GetPackageFiles
-> Path Abs File
-> RIO
     env
     (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath], Set (Path Abs File),
      [PackageWarning])
GetPackageFiles
-> forall env.
   HasEnvConfig env =>
   Path Abs File
   -> RIO
        env
        (Map NamedComponent (Map ModuleName (Path Abs File)),
         Map NamedComponent [DotCabalPath], Set (Path Abs File),
         [PackageWarning])
getPackageFiles (Package -> GetPackageFiles
packageFiles (LocalPackage -> Package
lpPackage LocalPackage
lp)) (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
        (LocalPackage, Map NamedComponent [Path Abs File])
-> RIO env (LocalPackage, Map NamedComponent [Path Abs File])
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalPackage
lp, ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Path Abs File)
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> b) -> [a] -> [b]
map DotCabalPath -> Path Abs File
dotCabalGetPath) Map NamedComponent [DotCabalPath]
compFiles)
    let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
        foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents =
            (Path Abs File -> (Path Abs File, [(PackageName, NamedComponent)]))
-> [Path Abs File]
-> [(Path Abs File, [(PackageName, NamedComponent)])]
forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
fp -> (Path Abs File
fp, ) ([(PackageName, NamedComponent)]
 -> (Path Abs File, [(PackageName, NamedComponent)]))
-> [(PackageName, NamedComponent)]
-> (Path Abs File, [(PackageName, NamedComponent)])
forall a b. (a -> b) -> a -> b
$ [(PackageName, NamedComponent)] -> [(PackageName, NamedComponent)]
forall a. Ord a => [a] -> [a]
sort ([(PackageName, NamedComponent)]
 -> [(PackageName, NamedComponent)])
-> [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> a -> b
$
                        ((LocalPackage, Map NamedComponent [Path Abs File])
 -> [(PackageName, NamedComponent)])
-> [(LocalPackage, Map NamedComponent [Path Abs File])]
-> [(PackageName, NamedComponent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(LocalPackage
lp, Map NamedComponent [Path Abs File]
files) -> ((NamedComponent, [Path Abs File])
 -> (PackageName, NamedComponent))
-> [(NamedComponent, [Path Abs File])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp), ) (NamedComponent -> (PackageName, NamedComponent))
-> ((NamedComponent, [Path Abs File]) -> NamedComponent)
-> (NamedComponent, [Path Abs File])
-> (PackageName, NamedComponent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, [Path Abs File]) -> NamedComponent
forall a b. (a, b) -> a
fst)
                                                       (((NamedComponent, [Path Abs File]) -> Bool)
-> [(NamedComponent, [Path Abs File])]
-> [(NamedComponent, [Path Abs File])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path Abs File -> [Path Abs File] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Path Abs File
fp ([Path Abs File] -> Bool)
-> ((NamedComponent, [Path Abs File]) -> [Path Abs File])
-> (NamedComponent, [Path Abs File])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, [Path Abs File]) -> [Path Abs File]
forall a b. (a, b) -> b
snd) (Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent [Path Abs File]
files))
                                  ) [(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages
                ) [Path Abs File]
fileTargets
    [Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results <- [(Path Abs File, [(PackageName, NamedComponent)])]
-> ((Path Abs File, [(PackageName, NamedComponent)])
    -> RIO
         env
         (Either
            (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> RIO
     env
     [Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents (((Path Abs File, [(PackageName, NamedComponent)])
  -> RIO
       env
       (Either
          (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
 -> RIO
      env
      [Either
         (Path Abs File) (Path Abs File, (PackageName, NamedComponent))])
-> ((Path Abs File, [(PackageName, NamedComponent)])
    -> RIO
         env
         (Either
            (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> RIO
     env
     [Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
forall a b. (a -> b) -> a -> b
$ \(Path Abs File
fp, [(PackageName, NamedComponent)]
xs) ->
        case [(PackageName, NamedComponent)]
xs of
            [] -> do
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
                    [ StyleDoc
"Couldn't find a component for file target" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                      StyleDoc
". This means that the correct ghc options might not be used."
                    , StyleDoc
"Attempting to load the file anyway."
                    ]
                Either
  (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
 -> RIO
      env
      (Either
         (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ Path Abs File
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. a -> Either a b
Left Path Abs File
fp
            [(PackageName, NamedComponent)
x] -> do
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    StyleDoc
"Using configuration for" StyleDoc -> StyleDoc -> StyleDoc
<+> (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x StyleDoc -> StyleDoc -> StyleDoc
<+>
                    StyleDoc
"to load" StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
                Either
  (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
 -> RIO
      env
      (Either
         (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, (PackageName, NamedComponent))
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
            ((PackageName, NamedComponent)
x:[(PackageName, NamedComponent)]
_) -> do
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    StyleDoc
"Multiple components contain file target" StyleDoc -> StyleDoc -> StyleDoc
<+>
                    Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
<+>
                    [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
intersperse StyleDoc
", " (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent [(PackageName, NamedComponent)]
xs)) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
                    StyleDoc
"Guessing the first one," StyleDoc -> StyleDoc -> StyleDoc
<+> (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                Either
  (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
 -> RIO
      env
      (Either
         (Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
     env
     (Either
        (Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, (PackageName, NamedComponent))
-> Either
     (Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
    let ([Path Abs File]
extraFiles, [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles) = [Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
-> ([Path Abs File],
    [(Path Abs File, (PackageName, NamedComponent))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results
        targetMap :: Map PackageName Target
targetMap =
            (Map PackageName Target
 -> Map PackageName Target -> Map PackageName Target)
-> Map PackageName Target
-> [Map PackageName Target]
-> Map PackageName Target
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map PackageName Target
-> Map PackageName Target -> Map PackageName Target
forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
forall k a. Map k a
M.empty ([Map PackageName Target] -> Map PackageName Target)
-> [Map PackageName Target] -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$
            ((Path Abs File, (PackageName, NamedComponent))
 -> Map PackageName Target)
-> [(Path Abs File, (PackageName, NamedComponent))]
-> [Map PackageName Target]
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
_, (PackageName
name, NamedComponent
comp)) -> PackageName -> Target -> Map PackageName Target
forall k a. k -> a -> Map k a
M.singleton PackageName
name (Set NamedComponent -> Target
TargetComps (NamedComponent -> Set NamedComponent
forall a. a -> Set a
S.singleton NamedComponent
comp)))
                [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
        infoMap :: Map PackageName [Path Abs File]
infoMap =
            (Map PackageName [Path Abs File]
 -> Map PackageName [Path Abs File]
 -> Map PackageName [Path Abs File])
-> Map PackageName [Path Abs File]
-> [Map PackageName [Path Abs File]]
-> Map PackageName [Path Abs File]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (([Path Abs File] -> [Path Abs File] -> [Path Abs File])
-> Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
(<>)) Map PackageName [Path Abs File]
forall k a. Map k a
M.empty ([Map PackageName [Path Abs File]]
 -> Map PackageName [Path Abs File])
-> [Map PackageName [Path Abs File]]
-> Map PackageName [Path Abs File]
forall a b. (a -> b) -> a -> b
$
            ((Path Abs File, (PackageName, NamedComponent))
 -> Map PackageName [Path Abs File])
-> [(Path Abs File, (PackageName, NamedComponent))]
-> [Map PackageName [Path Abs File]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
fp, (PackageName
name, NamedComponent
_)) -> PackageName -> [Path Abs File] -> Map PackageName [Path Abs File]
forall k a. k -> a -> Map k a
M.singleton PackageName
name [Path Abs File
fp])
                [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
    (Map PackageName Target, Map PackageName [Path Abs File],
 [Path Abs File])
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName Target
targetMap, Map PackageName [Path Abs File]
infoMap, [Path Abs File]
extraFiles)

getAllLocalTargets
    :: HasEnvConfig env
    => GhciOpts
    -> Map PackageName Target
    -> Maybe (Map PackageName Target)
    -> Map PackageName LocalPackage
    -> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets :: GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
    -- Use the 'mainIsTargets' as normal targets, for CLI concision. See
    -- #1845. This is a little subtle - we need to do the target parsing
    -- independently in order to handle the case where no targets are
    -- specified.
    let targets :: Map PackageName Target
targets = Map PackageName Target
-> (Map PackageName Target -> Map PackageName Target)
-> Maybe (Map PackageName Target)
-> Map PackageName Target
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PackageName Target
targets0 (Map PackageName Target
-> Map PackageName Target -> Map PackageName Target
forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
targets0) Maybe (Map PackageName Target)
mainIsTargets
    Map PackageName ProjectPackage
packages <- Getting
  (Map PackageName ProjectPackage)
  env
  (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   env
   (Map PackageName ProjectPackage)
 -> RIO env (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL((EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
 -> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapGetting (Map PackageName ProjectPackage) EnvConfig SourceMap
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> SourceMap -> Const (Map PackageName ProjectPackage) SourceMap)
-> (Map PackageName ProjectPackage
    -> Const
         (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
-> EnvConfig
-> Const (Map PackageName ProjectPackage) EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SourceMap -> Map PackageName ProjectPackage)
-> SimpleGetter SourceMap (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> Map PackageName ProjectPackage
smProject
    -- Find all of the packages that are directly demanded by the
    -- targets.
    let directlyWanted :: [(PackageName, (Path Abs File, Target))]
directlyWanted = (((PackageName, ProjectPackage)
  -> Maybe (PackageName, (Path Abs File, Target)))
 -> [(PackageName, ProjectPackage)]
 -> [(PackageName, (Path Abs File, Target))])
-> [(PackageName, ProjectPackage)]
-> ((PackageName, ProjectPackage)
    -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PackageName, ProjectPackage)
 -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName ProjectPackage
packages) (((PackageName, ProjectPackage)
  -> Maybe (PackageName, (Path Abs File, Target)))
 -> [(PackageName, (Path Abs File, Target))])
-> ((PackageName, ProjectPackage)
    -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
          \(PackageName
name, ProjectPackage
pp) ->
                case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName Target
targets of
                  Just Target
simpleTargets -> (PackageName, (Path Abs File, Target))
-> Maybe (PackageName, (Path Abs File, Target))
forall a. a -> Maybe a
Just (PackageName
name, (ProjectPackage -> Path Abs File
ppCabalFP ProjectPackage
pp, Target
simpleTargets))
                  Maybe Target
Nothing -> Maybe (PackageName, (Path Abs File, Target))
forall a. Maybe a
Nothing
    -- Figure out
    let extraLoadDeps :: [(PackageName, (Path Abs File, Target))]
extraLoadDeps = Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps Bool
ghciLoadLocalDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
directlyWanted
    if (Bool
ghciSkipIntermediate Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ghciLoadLocalDeps) Bool -> Bool -> Bool
|| [(PackageName, (Path Abs File, Target))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
        then [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(PackageName, (Path Abs File, Target))]
directlyWanted
        else do
            let extraList :: Utf8Builder
extraList =
                  [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat ([Utf8Builder] -> Utf8Builder) -> [Utf8Builder] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (((PackageName, (Path Abs File, Target)) -> Utf8Builder)
-> [(PackageName, (Path Abs File, Target))] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> ((PackageName, (Path Abs File, Target)) -> String)
-> (PackageName, (Path Abs File, Target))
-> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> String)
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps)
            if Bool
ghciLoadLocalDeps
                then Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"The following libraries will also be loaded into GHCi because " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"they are local dependencies of your targets, and you specified --load-local-deps:\n    " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
extraList
                else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"The following libraries will also be loaded into GHCi because " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"they are intermediate dependencies of your targets:\n    " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
extraList Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"\n(Use --skip-intermediate-deps to omit these)"
            [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(PackageName, (Path Abs File, Target))]
directlyWanted [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)

getAllNonLocalTargets
    :: Map PackageName Target
    -> RIO env [PackageName]
getAllNonLocalTargets :: Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
targets = do
  let isNonLocal :: Target -> Bool
isNonLocal (TargetAll PackageType
PTDependency) = Bool
True
      isNonLocal Target
_ = Bool
False
  [PackageName] -> RIO env [PackageName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageName] -> RIO env [PackageName])
-> [PackageName] -> RIO env [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> PackageName)
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Target) -> PackageName
forall a b. (a, b) -> a
fst ([(PackageName, Target)] -> [PackageName])
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> Bool)
-> [(PackageName, Target)] -> [(PackageName, Target)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
isNonLocal (Target -> Bool)
-> ((PackageName, Target) -> Target)
-> (PackageName, Target)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, Target) -> Target
forall a b. (a, b) -> b
snd) (Map PackageName Target -> [(PackageName, Target)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName Target
targets)

buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [Text]
localTargets = do
    let targets :: [Text]
targets = [Text]
localTargets [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
ghciAdditionalPackages
    -- If necessary, do the build, for local packagee targets, only do
    -- 'initialBuildSteps'.
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ghciNoBuild Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targets)) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        -- only new local targets could appear here
        Either SomeException ()
eres <- RIO env () -> RIO env (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env () -> RIO env (Either SomeException ()))
-> RIO env () -> RIO env (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Text] -> RIO env () -> RIO env ()
forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets [Text]
targets (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing
        case Either SomeException ()
eres of
            Right () -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Left SomeException
err -> do
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
forall a. IsString a => String -> a
fromString (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
                StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
"Build failed, but trying to launch GHCi anyway"

checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages :: [String] -> m [PackageName]
checkAdditionalPackages [String]
pkgs = [String] -> (String -> m PackageName) -> m [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgs ((String -> m PackageName) -> m [PackageName])
-> (String -> m PackageName) -> m [PackageName]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
    let mres :: Maybe PackageName
mres = (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier -> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
name)
            Maybe PackageName -> Maybe PackageName -> Maybe PackageName
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing String
name
    m PackageName
-> (PackageName -> m PackageName)
-> Maybe PackageName
-> m PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GhciException -> m PackageName
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GhciException -> m PackageName) -> GhciException -> m PackageName
forall a b. (a -> b) -> a -> b
$ String -> GhciException
InvalidPackageOption String
name) PackageName -> m PackageName
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageName
mres

runGhci
    :: HasEnvConfig env
    => GhciOpts
    -> [(PackageName, (Path Abs File, Target))]
    -> Maybe (Path Abs File)
    -> [GhciPkgInfo]
    -> [Path Abs File]
    -> [PackageName]
    -> RIO env ()
runGhci :: GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [(PackageName, (Path Abs File, Target))]
targets Maybe (Path Abs File)
mainFile [GhciPkgInfo]
pkgs [Path Abs File]
extraFiles [PackageName]
exposePackages = do
    Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
    let pkgopts :: [String]
pkgopts = [String]
hidePkgOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
genOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
        shouldHidePackages :: Bool
shouldHidePackages =
          Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not ([GhciPkgInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages)) Maybe Bool
ghciHidePackages
        hidePkgOpts :: [String]
hidePkgOpts =
          if Bool
shouldHidePackages
            then
              [String
"-hide-all-packages"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              -- This is necessary, because current versions of ghci
              -- will entirely fail to start if base isn't visible. This
              -- is because it tries to use the interpreter to set
              -- buffering options on standard IO.
              (if [(PackageName, (Path Abs File, Target))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else []) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              (PackageName -> [String]) -> [PackageName] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\PackageName
n -> [String
"-package", PackageName -> String
packageNameString PackageName
n]) [PackageName]
exposePackages
            else []
        oneWordOpts :: BuildInfoOpts -> [String]
oneWordOpts BuildInfoOpts
bio
            | Bool
shouldHidePackages = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioPackageFlags BuildInfoOpts
bio
            | Bool
otherwise = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio
        genOpts :: [String]
genOpts = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ((GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
oneWordOpts (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs)
        ([String]
omittedOpts, [String]
ghcOpts) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
badForGhci ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$
            (GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
bioOpts (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
              ( Map ApplyGhcOptions [Text] -> [Text]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config) -- include everything, locals, and targets
             [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (GhciPkgInfo -> [Text]) -> [GhciPkgInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions (PackageName -> [Text])
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs
              )
        getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PackageName
pkg (Config -> Map PackageName [Text]
configGhcOptionsByName Config
config)
        badForGhci :: String -> Bool
badForGhci String
x =
            String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"-O" String
x Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
            (Utf8Builder
"The following GHC options are incompatible with GHCi and have not been passed to it: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
" " (String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> [String] -> [Utf8Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts)))
    Path Abs Dir
oiDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
    let odir :: [String]
odir =
            [ String
"-odir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
            , String
"-hidir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir ]
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Configuring GHCi with the following packages: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
      [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " ((GhciPkgInfo -> Utf8Builder) -> [GhciPkgInfo] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> (GhciPkgInfo -> String) -> GhciPkgInfo -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString (PackageName -> String)
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs))
    String
compilerExeName <- Getting String env String -> RIO env String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting String env String -> RIO env String)
-> Getting String env String -> RIO env String
forall a b. (a -> b) -> a -> b
$ Getting String env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLGetting String env CompilerPaths
-> ((String -> Const String String)
    -> CompilerPaths -> Const String CompilerPaths)
-> Getting String env String
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 CompilerPaths -> Path Abs File
cpCompilerGetting String CompilerPaths (Path Abs File)
-> ((String -> Const String String)
    -> Path Abs File -> Const String (Path Abs File))
-> (String -> Const String String)
-> CompilerPaths
-> Const String CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Path Abs File -> String) -> SimpleGetter (Path Abs File) String
forall s a. (s -> a) -> SimpleGetter s a
to Path Abs File -> String
forall b t. Path b t -> String
toFilePath
    let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
            ProcessContext
menv <- IO ProcessContext -> RIO env ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
            ProcessContext -> RIO env b -> RIO env b
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO env b
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
                 (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand)
                 ((String
"--interactive" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                 -- This initial "-i" resets the include directories to
                 -- not include CWD. If there aren't any packages, CWD
                 -- is included.
                  (if [GhciPkgInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then [String] -> [String]
forall a. a -> a
id else (String
"-i" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: )) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                  [String]
odir [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
extras [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ghciGhcOptions [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ghciArgs)
        -- TODO: Consider optimizing this check. Perhaps if no
        -- "with-ghc" is specified, assume that it is not using intero.
        checkIsIntero :: RIO env Bool
checkIsIntero =
            -- Optimization dependent on the behavior of renderScript -
            -- it doesn't matter if it's intero or ghci when loading
            -- multiple packages.
            case [GhciPkgInfo]
pkgs of
                [GhciPkgInfo
_] -> do
                    ProcessContext
menv <- IO ProcessContext -> RIO env ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
                    String
output <- ProcessContext -> RIO env String -> RIO env String
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
                            (RIO env String -> RIO env String)
-> RIO env String -> RIO env String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO env String
forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand) [String
"--version"]
                    Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ String
"Intero" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
output
                [GhciPkgInfo]
_ -> Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    -- Since usage of 'exec' does not return, we cannot do any cleanup
    -- on ghci exit. So, instead leave the generated files. To make this
    -- more efficient and avoid gratuitous generation of garbage, the
    -- file names are determined by hashing. This also has the nice side
    -- effect of making it possible to copy the ghci invocation out of
    -- the log and have it still work.
    Path Abs Dir
tmpDirectory <-
        (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirHaskellStackGhci) (Path Abs Dir -> Path Abs Dir)
-> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (String -> RIO env (Path Abs Dir))
-> RIO env String -> RIO env (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> RIO env String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCanonicalTemporaryDirectory)
    Path Abs Dir
ghciDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
    Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
    Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
    [String]
macrosOptions <- Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
    if Bool
ghciNoLoadModules
        then [String] -> RIO env ()
forall env b.
(HasProcessContext env, HasLogFunc env) =>
[String] -> RIO env b
execGhci [String]
macrosOptions
        else do
            [GhciPkgInfo] -> RIO env ()
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
            Bool
isIntero <- RIO env Bool
checkIsIntero
            [String]
scriptOptions <- Path Abs Dir -> GhciScript -> RIO env [String]
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
tmpDirectory (Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
ghciOnlyMain [Path Abs File]
extraFiles)
            [String] -> RIO env ()
forall env b.
(HasProcessContext env, HasLogFunc env) =>
[String] -> RIO env b
execGhci ([String]
macrosOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
scriptOptions)

writeMacrosFile :: HasTerm env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile :: Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
outputDirectory [GhciPkgInfo]
pkgs = do
    [Path Abs File]
fps <- ([[Maybe (Path Abs File)]] -> [Path Abs File])
-> RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Path Abs File] -> [Path Abs File]
forall a. Ord a => [a] -> [a]
nubOrd ([Path Abs File] -> [Path Abs File])
-> ([[Maybe (Path Abs File)]] -> [Path Abs File])
-> [[Maybe (Path Abs File)]]
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Path Abs File)] -> [Path Abs File]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Path Abs File)] -> [Path Abs File])
-> ([[Maybe (Path Abs File)]] -> [Maybe (Path Abs File)])
-> [[Maybe (Path Abs File)]]
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe (Path Abs File)]] -> [Maybe (Path Abs File)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File])
-> RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$
        [GhciPkgInfo]
-> (GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
-> RIO env [[Maybe (Path Abs File)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgInfo]
pkgs ((GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
 -> RIO env [[Maybe (Path Abs File)]])
-> (GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
-> RIO env [[Maybe (Path Abs File)]]
forall a b. (a -> b) -> a -> b
$ \GhciPkgInfo
pkg -> [(NamedComponent, BuildInfoOpts)]
-> ((NamedComponent, BuildInfoOpts)
    -> RIO env (Maybe (Path Abs File)))
-> RIO env [Maybe (Path Abs File)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts GhciPkgInfo
pkg) (((NamedComponent, BuildInfoOpts)
  -> RIO env (Maybe (Path Abs File)))
 -> RIO env [Maybe (Path Abs File)])
-> ((NamedComponent, BuildInfoOpts)
    -> RIO env (Maybe (Path Abs File)))
-> RIO env [Maybe (Path Abs File)]
forall a b. (a -> b) -> a -> b
$ \(NamedComponent
_, BuildInfoOpts
bio) -> do
            let cabalMacros :: Path Abs File
cabalMacros = BuildInfoOpts -> Path Abs File
bioCabalMacros BuildInfoOpts
bio
            Bool
exists <- IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
cabalMacros
            if Bool
exists
                then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
cabalMacros
                else do
                    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL [StyleDoc
"Didn't find expected autogen file:", Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalMacros]
                    Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing
    [ByteString]
files <- IO [ByteString] -> RIO env [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> RIO env [ByteString])
-> IO [ByteString] -> RIO env [ByteString]
forall a b. (a -> b) -> a -> b
$ (Path Abs File -> IO ByteString)
-> [Path Abs File] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ByteString
S8.readFile (String -> IO ByteString)
-> (Path Abs File -> String) -> Path Abs File -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
fps
    if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
files then [String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
        Path Abs File
out <- IO (Path Abs File) -> RIO env (Path Abs File)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File) -> RIO env (Path Abs File))
-> IO (Path Abs File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileCabalMacrosH (ByteString -> IO (Path Abs File))
-> ByteString -> IO (Path Abs File)
forall a b. (a -> b) -> a -> b
$
            [ByteString] -> ByteString
S8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") [ByteString]
files
        [String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-optP-include", String
"-optP" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
out]

writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String]
writeGhciScript :: Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
outputDirectory GhciScript
script = do
    Path Abs File
scriptPath <- IO (Path Abs File) -> m (Path Abs File)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File) -> m (Path Abs File))
-> IO (Path Abs File) -> m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileGhciScript (ByteString -> IO (Path Abs File))
-> ByteString -> IO (Path Abs File)
forall a b. (a -> b) -> a -> b
$
        ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GhciScript -> ByteString
scriptToLazyByteString GhciScript
script
    let scriptFilePath :: String
scriptFilePath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
scriptPath
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
setScriptPerms String
scriptFilePath
    [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-ghci-script=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
scriptFilePath]

writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFile ByteString
contents = do
    Path Rel Dir
relSha <- ByteString -> IO (Path Rel Dir)
forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes ByteString
contents
    let outDir :: Path Abs Dir
outDir = Path Abs Dir
outputDirectory Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relSha
        outFile :: Path Abs File
outFile = Path Abs Dir
outDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
    Bool
alreadyExists <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
outFile
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outDir
        Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outFile (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
contents
    Path Abs File -> IO (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
outFile

renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript :: Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
    let cdPhase :: GhciScript
cdPhase = case (Bool
isIntero, [GhciPkgInfo]
pkgs) of
          -- If only loading one package, set the cwd properly.
          -- Otherwise don't try. See
          -- https://github.com/commercialhaskell/stack/issues/3309
          (Bool
True, [GhciPkgInfo
pkg]) -> Path Abs Dir -> GhciScript
cmdCdGhc (GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
          (Bool, [GhciPkgInfo])
_ -> GhciScript
forall a. Monoid a => a
mempty
        addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (Set (Either ModuleName (Path Abs File)) -> GhciScript)
-> Set (Either ModuleName (Path Abs File)) -> GhciScript
forall a b. (a -> b) -> a -> b
$ [Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((ModuleName -> Either ModuleName (Path Abs File))
-> [ModuleName] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either ModuleName (Path Abs File)
forall a b. a -> Either a b
Left [ModuleName]
allModules [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
forall a. [a] -> [a] -> [a]
++ [Either ModuleName (Path Abs File)]
forall a. [Either a (Path Abs File)]
addMain)
        addMain :: [Either a (Path Abs File)]
addMain = case Maybe (Path Abs File)
mainFile of
            Just Path Abs File
path -> [Path Abs File -> Either a (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
path]
            Maybe (Path Abs File)
_ -> []
        modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule (Set ModuleName -> GhciScript) -> Set ModuleName -> GhciScript
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
        allModules :: [ModuleName]
allModules = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
nubOrd ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (GhciPkgInfo -> [ModuleName]) -> [GhciPkgInfo] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleMap -> [ModuleName]
forall k a. Map k a -> [k]
M.keys (ModuleMap -> [ModuleName])
-> (GhciPkgInfo -> ModuleMap) -> GhciPkgInfo -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> ModuleMap
ghciPkgModules) [GhciPkgInfo]
pkgs
    case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
        [] ->
          if Bool
onlyMain
            then GhciScript
cdPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> if Maybe (Path Abs File) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList [Either ModuleName (Path Abs File)]
forall a. [Either a (Path Abs File)]
addMain) else GhciScript
forall a. Monoid a => a
mempty
            else GhciScript
cdPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> GhciScript
addPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
        [Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((Path Abs File -> Either ModuleName (Path Abs File))
-> [Path Abs File] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> Either ModuleName (Path Abs File)
forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))

-- Hacky check if module / main phase should be omitted. This should be
-- improved if / when we have a better per-component load.
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets = (GhciPkgInfo -> [Path Abs File])
-> [GhciPkgInfo] -> [Path Abs File]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Path Abs File]] -> [Path Abs File])
-> (GhciPkgInfo -> [[Path Abs File]])
-> GhciPkgInfo
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Path Abs File] -> [[Path Abs File]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Path Abs File] -> [[Path Abs File]])
-> (GhciPkgInfo -> Maybe [Path Abs File])
-> GhciPkgInfo
-> [[Path Abs File]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> Maybe [Path Abs File]
ghciPkgTargetFiles)

-- | Figure out the main-is file to load based on the targets. Asks the
-- user for input if there is more than one candidate main-is file.
figureOutMainFile
    :: HasRunner env
    => BuildOpts
    -> Maybe (Map PackageName Target)
    -> [(PackageName, (Path Abs File, Target))]
    -> [GhciPkgInfo]
    -> RIO env (Maybe (Path Abs File))
figureOutMainFile :: BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
targets0 [GhciPkgInfo]
packages = do
    case [(PackageName, NamedComponent, Path Abs File)]
candidates of
        [] -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing
        [c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using main module: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display ((PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate (PackageName, NamedComponent, Path Abs File)
c))
                           Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp)
        (PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
          RIO env () -> RIO env ()
forall env a. HasLogFunc env => RIO env a -> RIO env a
borderedWarning (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"The main module to load is ambiguous. Candidates are: "
            [Text] -> (Text -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (((PackageName, NamedComponent, Path Abs File) -> Text)
-> [(PackageName, NamedComponent, Path Abs File)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display)
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                Utf8Builder
"You can specify which one to pick by: "
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Specifying targets to stack ghci e.g. stack ghci " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display ( (PackageName, NamedComponent, Path Abs File) -> Text
forall c. (PackageName, NamedComponent, c) -> Text
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate))
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Specifying what the main is e.g. stack ghci " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display ((PackageName, NamedComponent, Path Abs File) -> Text
forall c. (PackageName, NamedComponent, c) -> Text
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate))
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Choosing from the candidate above [1.." Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"]")
          IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
  where
    targets :: Map PackageName Target
targets = Map PackageName Target
-> Maybe (Map PackageName Target) -> Map PackageName Target
forall a. a -> Maybe a -> a
fromMaybe ([(PackageName, Target)] -> Map PackageName Target
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, Target)] -> Map PackageName Target)
-> [(PackageName, Target)] -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ ((PackageName, (Path Abs File, Target)) -> (PackageName, Target))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Target)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
k, (Path Abs File
_, Target
x)) -> (PackageName
k, Target
x)) [(PackageName, (Path Abs File, Target))]
targets0)
                        Maybe (Map PackageName Target)
mainIsTargets
    candidates :: [(PackageName, NamedComponent, Path Abs File)]
candidates = do
        GhciPkgInfo
pkg <- [GhciPkgInfo]
packages
        case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg) Map PackageName Target
targets of
            Maybe Target
Nothing -> []
            Just Target
target -> do
                (NamedComponent
component,[Path Abs File]
mains) <-
                    Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent [Path Abs File]
 -> [(NamedComponent, [Path Abs File])])
-> Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall a b. (a -> b) -> a -> b
$
                    (NamedComponent -> [Path Abs File] -> Bool)
-> Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
wantedComponents)
                                    (GhciPkgInfo -> Map NamedComponent [Path Abs File]
ghciPkgMainIs GhciPkgInfo
pkg)
                Path Abs File
main <- [Path Abs File]
mains
                (PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)]
forall (m :: * -> *) a. Monad m => a -> m a
return (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg, NamedComponent
component, Path Abs File
main)
              where
                wantedComponents :: Set NamedComponent
wantedComponents =
                    BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target (GhciPkgInfo -> Package
ghciPkgPackage GhciPkgInfo
pkg)
    renderCandidate :: (PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName,NamedComponent
namedComponent,Path Abs File
mainIs) =
        let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> Text
candidateIndex = String -> Text
T.pack (String -> Text)
-> ([(PackageName, NamedComponent, Path Abs File)] -> String)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Maybe Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (PackageName, NamedComponent, Path Abs File)
c
            pkgNameText :: Text
pkgNameText = String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkgName)
        in  [(PackageName, NamedComponent, Path Abs File)] -> Text
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Package `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
pkgNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"' component " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            -- This is the format that can be directly copy-pasted as
            -- an argument to `stack ghci`.
            Text
pkgNameText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
namedComponent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
" with main-is file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            String -> Text
T.pack (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
mainIs)
    candidateIndices :: [Int]
candidateIndices = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) [Int
1 :: Int ..]
    userOption :: IO (Maybe (Path Abs File))
userOption = do
      Text
option <- Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
      let selected :: Int
selected = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
                      ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
                      (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
      case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
selected [Int]
candidateIndices  of
        Maybe Int
Nothing -> do
            String -> IO ()
putStrLn
              String
"Not loading any main modules, as no valid module selected"
            String -> IO ()
putStrLn String
""
            Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path Abs File)
forall a. Maybe a
Nothing
        Just Int
op -> do
            let (PackageName
_,NamedComponent
_,Path Abs File
fp) = [(PackageName, NamedComponent, Path Abs File)]
candidates [(PackageName, NamedComponent, Path Abs File)]
-> Int -> (PackageName, NamedComponent, Path Abs File)
forall a. [a] -> Int -> a
!! Int
op
            String -> IO ()
putStrLn
              (String
"Loading main module from candidate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Int -> String
forall a. Show a => a -> String
show (Int
op Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", --main-is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp)
            String -> IO ()
putStrLn String
""
            Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Abs File) -> IO (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp
    renderComp :: NamedComponent -> Text
renderComp NamedComponent
c =
        case NamedComponent
c of
            NamedComponent
CLib -> Text
"lib"
            CInternalLib Text
name -> Text
"internal-lib:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            CExe Text
name -> Text
"exe:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            CTest Text
name -> Text
"test:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            CBench Text
name -> Text
"bench:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    sampleTargetArg :: (PackageName, NamedComponent, c) -> Text
sampleTargetArg (PackageName
pkg,NamedComponent
comp,c
_) =
        String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkg) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
comp
    sampleMainIsArg :: (PackageName, NamedComponent, c) -> Text
sampleMainIsArg (PackageName
pkg,NamedComponent
comp,c
_) =
        Text
"--main-is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkg) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
comp

loadGhciPkgDescs
    :: HasEnvConfig env
    => BuildOptsCLI
    -> [(PackageName, (Path Abs File, Target))]
    -> RIO env [GhciPkgDesc]
loadGhciPkgDescs :: BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets =
    [(PackageName, (Path Abs File, Target))]
-> ((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
-> RIO env [GhciPkgDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PackageName, (Path Abs File, Target))]
localTargets (((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
 -> RIO env [GhciPkgDesc])
-> ((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
-> RIO env [GhciPkgDesc]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, (Path Abs File
cabalfp, Target
target)) ->
        BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalfp Target
target

-- | Load package description information for a ghci target.
loadGhciPkgDesc
    :: HasEnvConfig env
    => BuildOptsCLI
    -> PackageName
    -> Path Abs File
    -> Target
    -> RIO env GhciPkgDesc
loadGhciPkgDesc :: BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalfp Target
target = do
    EnvConfig
econfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
    ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
    let SourceMap{Map PackageName GlobalPackage
Map PackageName ProjectPackage
Map PackageName DepPackage
ActualCompiler
SMTargets
smTargets :: SourceMap -> SMTargets
smGlobal :: Map PackageName GlobalPackage
smDeps :: Map PackageName DepPackage
smProject :: Map PackageName ProjectPackage
smCompiler :: ActualCompiler
smTargets :: SMTargets
smGlobal :: SourceMap -> Map PackageName GlobalPackage
smDeps :: SourceMap -> Map PackageName DepPackage
smProject :: SourceMap -> Map PackageName ProjectPackage
smCompiler :: SourceMap -> ActualCompiler
..} = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
econfig
        -- Currently this source map is being build with
        -- the default targets
        sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
          (CommonPackage -> [Text]
cpGhcOptions (CommonPackage -> [Text])
-> (ProjectPackage -> CommonPackage) -> ProjectPackage -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
          Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (CommonPackage -> [Text]
cpGhcOptions (CommonPackage -> [Text])
-> (DepPackage -> CommonPackage) -> DepPackage -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
        sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
          (CommonPackage -> [Text]
cpCabalConfigOpts (CommonPackage -> [Text])
-> (ProjectPackage -> CommonPackage) -> ProjectPackage -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
          Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (CommonPackage -> [Text]
cpCabalConfigOpts (CommonPackage -> [Text])
-> (DepPackage -> CommonPackage) -> DepPackage -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
        config :: PackageConfig
config =
            PackageConfig :: Bool
-> Bool
-> Map FlagName Bool
-> [Text]
-> [Text]
-> ActualCompiler
-> Platform
-> PackageConfig
PackageConfig
            { packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
True
            , packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
True
            , packageConfigFlags :: Map FlagName Bool
packageConfigFlags = BuildOptsCLI -> PackageName -> Map FlagName Bool
getLocalFlags BuildOptsCLI
buildOptsCLI PackageName
name
            , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = [Text]
sourceMapGhcOptions
            , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = [Text]
sourceMapCabalConfigOpts
            , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
            , packageConfigPlatform :: Platform
packageConfigPlatform = Getting Platform EnvConfig Platform -> EnvConfig -> Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform EnvConfig Platform
forall env. HasPlatform env => Lens' env Platform
platformL EnvConfig
econfig
            }
    -- TODO we've already parsed this information, otherwise we
    -- wouldn't have figured out the cabalfp already. In the future:
    -- retain that GenericPackageDescription in the relevant data
    -- structures to avoid reparsing.
    (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
_cabalfp) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
    GenericPackageDescription
gpkgdesc <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings

    -- Source the package's *.buildinfo file created by configure if any. See
    -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters
    Path Rel File
buildinfofp <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (PackageName -> String
packageNameString PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".buildinfo")
    Bool
hasDotBuildinfo <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
    let mbuildinfofp :: Maybe (Path Abs File)
mbuildinfofp
          | Bool
hasDotBuildinfo = Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
          | Bool
otherwise = Maybe (Path Abs File)
forall a. Maybe a
Nothing
    Maybe HookedBuildInfo
mbuildinfo <- Maybe (Path Abs File)
-> (Path Abs File -> RIO env HookedBuildInfo)
-> RIO env (Maybe HookedBuildInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Path Abs File)
mbuildinfofp Path Abs File -> RIO env HookedBuildInfo
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m HookedBuildInfo
readDotBuildinfo
    let pdp :: PackageDescriptionPair
pdp = PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpkgdesc
        pkg :: Package
pkg =
            PackageConfig -> [Flag] -> PackageDescriptionPair -> Package
packageFromPackageDescription PackageConfig
config (GenericPackageDescription -> [Flag]
C.genPackageFlags GenericPackageDescription
gpkgdesc) (PackageDescriptionPair -> Package)
-> PackageDescriptionPair -> Package
forall a b. (a -> b) -> a -> b
$
            PackageDescriptionPair
-> (HookedBuildInfo -> PackageDescriptionPair)
-> Maybe HookedBuildInfo
-> PackageDescriptionPair
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              PackageDescriptionPair
pdp
              (\HookedBuildInfo
bi ->
               let PackageDescriptionPair PackageDescription
x PackageDescription
y = PackageDescriptionPair
pdp
                in PackageDescription -> PackageDescription -> PackageDescriptionPair
PackageDescriptionPair
                    (HookedBuildInfo -> PackageDescription -> PackageDescription
C.updatePackageDescription HookedBuildInfo
bi PackageDescription
x)
                    (HookedBuildInfo -> PackageDescription -> PackageDescription
C.updatePackageDescription HookedBuildInfo
bi PackageDescription
y))
              Maybe HookedBuildInfo
mbuildinfo
    GhciPkgDesc -> RIO env GhciPkgDesc
forall (m :: * -> *) a. Monad m => a -> m a
return GhciPkgDesc :: Package -> Path Abs File -> Target -> GhciPkgDesc
GhciPkgDesc
      { ghciDescPkg :: Package
ghciDescPkg = Package
pkg
      , ghciDescCabalFp :: Path Abs File
ghciDescCabalFp = Path Abs File
cabalfp
      , ghciDescTarget :: Target
ghciDescTarget = Target
target
      }

getGhciPkgInfos
    :: HasEnvConfig env
    => InstallMap
    -> [PackageName]
    -> Maybe (Map PackageName [Path Abs File])
    -> [GhciPkgDesc]
    -> RIO env [GhciPkgInfo]
getGhciPkgInfos :: InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets [GhciPkgDesc]
localTargets = do
    (InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let localLibs :: [PackageName]
localLibs =
            [ Package -> PackageName
packageName (GhciPkgDesc -> Package
ghciDescPkg GhciPkgDesc
desc)
            | GhciPkgDesc
desc <- [GhciPkgDesc]
localTargets
            , (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
isCLib (GhciPkgDesc -> Target
ghciDescTarget GhciPkgDesc
desc)
            ]
    [GhciPkgDesc]
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgDesc]
localTargets ((GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo])
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall a b. (a -> b) -> a -> b
$ \GhciPkgDesc
pkgDesc ->
      InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
localLibs [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc

-- | Make information necessary to load the given package in GHCi.
makeGhciPkgInfo
    :: HasEnvConfig env
    => InstallMap
    -> InstalledMap
    -> [PackageName]
    -> [PackageName]
    -> Maybe (Map PackageName [Path Abs File])
    -> GhciPkgDesc
    -> RIO env GhciPkgInfo
makeGhciPkgInfo :: InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc = do
    BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
    let pkg :: Package
pkg = GhciPkgDesc -> Package
ghciDescPkg GhciPkgDesc
pkgDesc
        cabalfp :: Path Abs File
cabalfp = GhciPkgDesc -> Path Abs File
ghciDescCabalFp GhciPkgDesc
pkgDesc
        target :: Target
target = GhciPkgDesc -> Target
ghciDescTarget GhciPkgDesc
pkgDesc
        name :: PackageName
name = Package -> PackageName
packageName Package
pkg
    (Map NamedComponent (Map ModuleName (Path Abs File))
mods,Map NamedComponent [DotCabalPath]
files,Map NamedComponent BuildInfoOpts
opts) <- GetPackageOpts
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO
     env
     (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath],
      Map NamedComponent BuildInfoOpts)
GetPackageOpts
-> forall env.
   HasEnvConfig env =>
   InstallMap
   -> InstalledMap
   -> [PackageName]
   -> [PackageName]
   -> Path Abs File
   -> RIO
        env
        (Map NamedComponent (Map ModuleName (Path Abs File)),
         Map NamedComponent [DotCabalPath],
         Map NamedComponent BuildInfoOpts)
getPackageOpts (Package -> GetPackageOpts
packageOpts Package
pkg) InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Path Abs File
cabalfp
    let filteredOpts :: Map NamedComponent BuildInfoOpts
filteredOpts = Map NamedComponent BuildInfoOpts
-> Map NamedComponent BuildInfoOpts
forall a. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
        filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = (NamedComponent -> a -> Bool)
-> Map NamedComponent a -> Map NamedComponent a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
allWanted)
        allWanted :: Set NamedComponent
allWanted = BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target Package
pkg
    GhciPkgInfo -> RIO env GhciPkgInfo
forall (m :: * -> *) a. Monad m => a -> m a
return
        GhciPkgInfo :: PackageName
-> [(NamedComponent, BuildInfoOpts)]
-> Path Abs Dir
-> ModuleMap
-> [Path Abs File]
-> Map NamedComponent [Path Abs File]
-> Maybe [Path Abs File]
-> Package
-> GhciPkgInfo
GhciPkgInfo
        { ghciPkgName :: PackageName
ghciPkgName = PackageName
name
        , ghciPkgOpts :: [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts = Map NamedComponent BuildInfoOpts
-> [(NamedComponent, BuildInfoOpts)]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
        , ghciPkgDir :: Path Abs Dir
ghciPkgDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp
        , ghciPkgModules :: ModuleMap
ghciPkgModules = [ModuleMap] -> ModuleMap
unionModuleMaps ([ModuleMap] -> ModuleMap) -> [ModuleMap] -> ModuleMap
forall a b. (a -> b) -> a -> b
$
          ((NamedComponent, Map ModuleName (Path Abs File)) -> ModuleMap)
-> [(NamedComponent, Map ModuleName (Path Abs File))]
-> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map (\(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> (Path Abs File
 -> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> Map ModuleName (Path Abs File) -> ModuleMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\Path Abs File
fp -> Path Abs File
-> Set (PackageName, NamedComponent)
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp ((PackageName, NamedComponent) -> Set (PackageName, NamedComponent)
forall a. a -> Set a
S.singleton (Package -> PackageName
packageName Package
pkg, NamedComponent
comp))) Map ModuleName (Path Abs File)
mp)
              (Map NamedComponent (Map ModuleName (Path Abs File))
-> [(NamedComponent, Map ModuleName (Path Abs File))]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent (Map ModuleName (Path Abs File))
-> Map NamedComponent (Map ModuleName (Path Abs File))
forall a. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
        , ghciPkgMainIs :: Map NamedComponent [Path Abs File]
ghciPkgMainIs = ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
        , ghciPkgCFiles :: [Path Abs File]
ghciPkgCFiles = [[Path Abs File]] -> [Path Abs File]
forall a. Monoid a => [a] -> a
mconcat (Map NamedComponent [Path Abs File] -> [[Path Abs File]]
forall k a. Map k a -> [a]
M.elems (Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall a. Map NamedComponent a -> Map NamedComponent a
filterWanted (([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath) Map NamedComponent [DotCabalPath]
files)))
        , ghciPkgTargetFiles :: Maybe [Path Abs File]
ghciPkgTargetFiles = Maybe (Map PackageName [Path Abs File])
mfileTargets Maybe (Map PackageName [Path Abs File])
-> (Map PackageName [Path Abs File] -> Maybe [Path Abs File])
-> Maybe [Path Abs File]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageName
-> Map PackageName [Path Abs File] -> Maybe [Path Abs File]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name
        , ghciPkgPackage :: Package
ghciPkgPackage = Package
pkg
        }

-- NOTE: this should make the same choices as the components code in
-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic
-- (differently).
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
_ (TargetComps Set NamedComponent
cs) Package
_ = Set NamedComponent
cs
wantedPackageComponents BuildOpts
bopts (TargetAll PackageType
PTProject) Package
pkg = [NamedComponent] -> Set NamedComponent
forall a. Ord a => [a] -> Set a
S.fromList ([NamedComponent] -> Set NamedComponent)
-> [NamedComponent] -> Set NamedComponent
forall a b. (a -> b) -> a -> b
$
    (case Package -> PackageLibraries
packageLibraries Package
pkg of
       PackageLibraries
NoLibraries -> []
       HasLibraries Set Text
names -> NamedComponent
CLib NamedComponent -> [NamedComponent] -> [NamedComponent]
forall a. a -> [a] -> [a]
: (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (Set Text -> [Text]
forall a. Set a -> [a]
S.toList Set Text
names)) [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. [a] -> [a] -> [a]
++
    (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe (Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Package -> Set Text
packageExes Package
pkg)) [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<>
    (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
pkg) [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<>
    (if BuildOpts -> Bool
boptsTests BuildOpts
bopts then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest (Map Text TestSuiteInterface -> [Text]
forall k a. Map k a -> [k]
M.keys (Package -> Map Text TestSuiteInterface
packageTests Package
pkg)) else []) [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<>
    (if BuildOpts -> Bool
boptsBenchmarks BuildOpts
bopts then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench (Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Package -> Set Text
packageBenchmarks Package
pkg)) else [])
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = Set NamedComponent
forall a. Set a
S.empty

checkForIssues :: HasLogFunc env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs = do
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Text]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
issues) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RIO env () -> RIO env ()
forall env a. HasLogFunc env => RIO env a -> RIO env a
borderedWarning (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Warning: There are cabal settings for this project which may prevent GHCi from loading your code properly."
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"In some cases it can also load some projects which would otherwise fail to build."
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
        (Text -> RIO env ()) -> [Text] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display) ([Text] -> RIO env ()) -> [Text] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Text] -> [[Text]] -> [Text]
forall a. [a] -> [[a]] -> [a]
intercalate [Text
""] [[Text]]
issues
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files."
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"It isn't yet possible to load multiple packages into GHCi in all cases - see"
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"https://ghc.haskell.org/trac/ghc/ticket/10827"
  where
    issues :: [[Text]]
issues = [[[Text]]] -> [[Text]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String -> [Text] -> [[Text]]
mixedFlag String
"-XNoImplicitPrelude"
          [ Text
"-XNoImplicitPrelude will be used, but GHCi will likely fail to build things which depend on the implicit prelude." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XCPP"
          [ Text
"-XCPP will be used, but it can cause issues with multiline strings."
          , Text
"See https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps"
          ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XNoTraditionalRecordSyntax"
          [ Text
"-XNoTraditionalRecordSyntax will be used, but it break modules which use record syntax." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XTemplateHaskell"
          [ Text
"-XTemplateHaskell will be used, but it may cause compilation issues due to different parsing of '$' when there's no space after it." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XQuasiQuotes"
          [ Text
"-XQuasiQuotes will be used, but it may cause parse failures due to a different meaning for list comprehension syntax like [x| ... ]" ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XSafe"
          [ Text
"-XSafe will be used, but it will fail to compile unsafe modules." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XArrows"
          [ Text
"-XArrows will be used, but it will cause non-arrow usages of proc, (-<), (-<<) to fail" ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XOverloadedStrings"
          [ Text
"-XOverloadedStrings will be used, but it can cause type ambiguity in code not usually compiled with it." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XOverloadedLists"
          [ Text
"-XOverloadedLists will be used, but it can cause type ambiguity in code not usually compiled with it." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XMonoLocalBinds"
          [ Text
"-XMonoLocalBinds will be used, but it can cause type errors in code which expects generalized local bindings." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XTypeFamilies"
          [ Text
"-XTypeFamilies will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XGADTs"
          [ Text
"-XGADTs will be used, but it implies -XMonoLocalBinds, and so can cause type errors in code which expects generalized local bindings." ]
        , String -> [Text] -> [[Text]]
mixedFlag String
"-XNewQualifiedOperators"
          [ Text
"-XNewQualifiedOperators will be used, but this will break usages of the old qualified operator syntax." ]
        ]
    mixedFlag :: String -> [Text] -> [[Text]]
mixedFlag String
flag [Text]
msgs =
        let x :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x = (String -> Bool)
-> ([(PackageName, NamedComponent)],
    [(PackageName, NamedComponent)])
partitionComps (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
flag) in
        [ [Text]
msgs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [Text]
showWhich ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x | ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> Bool
forall a a. (Eq a, Eq a) => ([a], [a]) -> Bool
mixedSettings ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x ]
    mixedSettings :: ([a], [a]) -> Bool
mixedSettings ([a]
xs, [a]
ys) = [a]
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [a]
ys [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
    showWhich :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [Text]
showWhich ([(PackageName, NamedComponent)]
haveIt, [(PackageName, NamedComponent)]
don'tHaveIt) =
        [ Text
"It is specified for:"
        , Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(PackageName, NamedComponent)] -> Text
renderPkgComponents [(PackageName, NamedComponent)]
haveIt
        , Text
"But not for: "
        , Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(PackageName, NamedComponent)] -> Text
renderPkgComponents [(PackageName, NamedComponent)]
don'tHaveIt
        ]
    partitionComps :: (String -> Bool)
-> ([(PackageName, NamedComponent)],
    [(PackageName, NamedComponent)])
partitionComps String -> Bool
f = ((((PackageName, NamedComponent), [String])
 -> (PackageName, NamedComponent))
-> [((PackageName, NamedComponent), [String])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent)
forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
xs, (((PackageName, NamedComponent), [String])
 -> (PackageName, NamedComponent))
-> [((PackageName, NamedComponent), [String])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent)
forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
ys)
      where
        ([((PackageName, NamedComponent), [String])]
xs, [((PackageName, NamedComponent), [String])]
ys) = (((PackageName, NamedComponent), [String]) -> Bool)
-> [((PackageName, NamedComponent), [String])]
-> ([((PackageName, NamedComponent), [String])],
    [((PackageName, NamedComponent), [String])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
f ([String] -> Bool)
-> (((PackageName, NamedComponent), [String]) -> [String])
-> ((PackageName, NamedComponent), [String])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, NamedComponent), [String]) -> [String]
forall a b. (a, b) -> b
snd) [((PackageName, NamedComponent), [String])]
compsWithOpts
    compsWithOpts :: [((PackageName, NamedComponent), [String])]
compsWithOpts = (((PackageName, NamedComponent), BuildInfoOpts)
 -> ((PackageName, NamedComponent), [String]))
-> [((PackageName, NamedComponent), BuildInfoOpts)]
-> [((PackageName, NamedComponent), [String])]
forall a b. (a -> b) -> [a] -> [b]
map (\((PackageName, NamedComponent)
k, BuildInfoOpts
bio) -> ((PackageName, NamedComponent)
k, BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioOpts BuildInfoOpts
bio)) [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios
    compsWithBios :: [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios =
        [ ((GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg, NamedComponent
c), BuildInfoOpts
bio)
        | GhciPkgInfo
pkg <- [GhciPkgInfo]
pkgs
        , (NamedComponent
c, BuildInfoOpts
bio) <- GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts GhciPkgInfo
pkg
        ]

borderedWarning :: HasLogFunc env => RIO env a -> RIO env a
borderedWarning :: RIO env a -> RIO env a
borderedWarning RIO env a
f = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"* * * * * * * *"
    a
x <- RIO env a
f
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"* * * * * * * *"
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
""
    a -> RIO env a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- TODO: Should this also tell the user the filepaths, not just the
-- module name?
checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules :: [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs = do
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        RIO env () -> RIO env ()
forall env a. HasLogFunc env => RIO env a -> RIO env a
borderedWarning (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
            StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ StyleDoc
"Multiple files use the same module name:" 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 (((ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))
 -> StyleDoc)
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName,
 Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates)
        -- MSS 2020-10-13 Disabling, may remove entirely in the future
        -- See: https://github.com/commercialhaskell/stack/issues/5407#issuecomment-707339928
        -- throwM LoadingDuplicateModules
  where
    duplicates :: [(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))]
    duplicates :: [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates =
      ((ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))
 -> Bool)
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ModuleName
_, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) -> Map (Path Abs File) (Set (PackageName, NamedComponent)) -> Int
forall k a. Map k a -> Int
M.size Map (Path Abs File) (Set (PackageName, NamedComponent))
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([(ModuleName,
   Map (Path Abs File) (Set (PackageName, NamedComponent)))]
 -> [(ModuleName,
      Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
      ModuleMap
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall k a. Map k a -> [(k, a)]
M.toList (ModuleMap
 -> [(ModuleName,
      Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> ModuleMap
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
      [ModuleMap] -> ModuleMap
unionModuleMaps ((GhciPkgInfo -> ModuleMap) -> [GhciPkgInfo] -> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map GhciPkgInfo -> ModuleMap
ghciPkgModules [GhciPkgInfo]
pkgs)
    prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> StyleDoc
    prettyDuplicate :: (ModuleName,
 Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate (ModuleName
mn, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) =
      Style -> StyleDoc -> StyleDoc
style Style
Error (ModuleName -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn) StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"found at the following paths" 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 (((Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc)
-> [(Path Abs File, Set (PackageName, NamedComponent))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Map (Path Abs File) (Set (PackageName, NamedComponent))
-> [(Path Abs File, Set (PackageName, NamedComponent))]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) (Set (PackageName, NamedComponent))
mp))
    fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
    fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Path Abs File
fp, Set (PackageName, NamedComponent)
comps) =
      Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc -> StyleDoc
parens ([StyleDoc] -> StyleDoc
fillSep (StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (Set (PackageName, NamedComponent)
-> [(PackageName, NamedComponent)]
forall a. Set a -> [a]
S.toList Set (PackageName, NamedComponent)
comps))))

targetWarnings
  :: HasBuildConfig env
  => [(PackageName, (Path Abs File, Target))]
  -> [PackageName]
  -> Maybe (Map PackageName [Path Abs File], [Path Abs File])
  -> RIO env ()
targetWarnings :: [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
nonLocalTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ String -> StyleDoc
flow String
"Some targets"
      , StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," ([StyleDoc] -> [StyleDoc]) -> [StyleDoc] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Good (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
nonLocalTargets
      , String -> StyleDoc
flow String
"are not local packages, and so cannot be directly loaded."
      , String -> StyleDoc
flow String
"In future versions of stack, this might be supported - see"
      , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1441"
      , StyleDoc
"."
      , String -> StyleDoc
flow String
"It can still be useful to specify these, as they will be passed to ghci via -package flags."
      ]
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(PackageName, (Path Abs File, Target))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& Maybe (Map PackageName [Path Abs File], [Path Abs File]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      SMWanted
smWanted <- Getting SMWanted env SMWanted -> RIO env SMWanted
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SMWanted env SMWanted -> RIO env SMWanted)
-> Getting SMWanted env SMWanted -> RIO env SMWanted
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig -> Const SMWanted BuildConfig)
 -> env -> Const SMWanted env)
-> ((SMWanted -> Const SMWanted SMWanted)
    -> BuildConfig -> Const SMWanted BuildConfig)
-> Getting SMWanted env SMWanted
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> SMWanted) -> SimpleGetter BuildConfig SMWanted
forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> SMWanted
bcSMWanted
      Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
          [ String -> StyleDoc
flow String
"No local targets specified, so a plain ghci will be started with no package hiding or package options."
          , StyleDoc
""
          , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"You are using snapshot: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                   RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display (SMWanted -> RawSnapshotLocation
smwSnapshotLocation SMWanted
smWanted)
          , StyleDoc
""
          , String -> StyleDoc
flow String
"If you want to use package hiding and options, then you can try one of the following:"
          , StyleDoc
""
          , [StyleDoc] -> StyleDoc
bulletedList
              [ [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"If you want to start a different project configuration than" StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
", then you can use"
                  , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack init"
                  , String -> StyleDoc
flow String
"to create a new stack.yaml for the packages in the current directory."
                  , StyleDoc
line
                  ]
              , String -> StyleDoc
flow String
"If you want to use the project configuration at" StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
", then you can add to its 'packages' field."
              ]
          , StyleDoc
""
          ]

-- Adds in intermediate dependencies between ghci targets. Note that it
-- will return a Lib component for these intermediate dependencies even
-- if they don't have a library (but that's fine for the usage within
-- this module).
--
-- If 'True' is passed for loadAllDeps, this loads all local deps, even
-- if they aren't intermediate.
getExtraLoadDeps
    :: Bool
    -> Map PackageName LocalPackage
    -> [(PackageName, (Path Abs File, Target))]
    -> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps :: Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps Bool
loadAllDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
targets =
    Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall k a. Map k a -> [(k, a)]
M.toList (Map PackageName (Path Abs File, Target)
 -> [(PackageName, (Path Abs File, Target))])
-> Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
    (\Map PackageName (Path Abs File, Target)
mp -> (Map PackageName (Path Abs File, Target)
 -> PackageName -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> [PackageName]
-> Map PackageName (Path Abs File, Target)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((PackageName
 -> Map PackageName (Path Abs File, Target)
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> PackageName
-> Map PackageName (Path Abs File, Target)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map PackageName (Path Abs File, Target)
mp (((PackageName, (Path Abs File, Target)) -> PackageName)
-> [(PackageName, (Path Abs File, Target))] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst [(PackageName, (Path Abs File, Target))]
targets)) (Map PackageName (Path Abs File, Target)
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
    (Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> a
id (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
    State (Map PackageName (Maybe (Path Abs File, Target))) ()
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall s a. State s a -> s -> s
execState (((PackageName, (Path Abs File, Target))
 -> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> [(PackageName, (Path Abs File, Target))]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PackageName
 -> StateT
      (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go ([PackageName]
 -> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> ((PackageName, (Path Abs File, Target)) -> [PackageName])
-> (PackageName, (Path Abs File, Target))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [PackageName]
getDeps (PackageName -> [PackageName])
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
targets)
              ([(PackageName, Maybe (Path Abs File, Target))]
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((PackageName, (Path Abs File, Target))
 -> (PackageName, Maybe (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Maybe (Path Abs File, Target))]
forall a b. (a -> b) -> [a] -> [b]
map (((Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> (PackageName, (Path Abs File, Target))
-> (PackageName, Maybe (Path Abs File, Target))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just) [(PackageName, (Path Abs File, Target))]
targets))
  where
    getDeps :: PackageName -> [PackageName]
    getDeps :: PackageName -> [PackageName]
getDeps PackageName
name =
        case PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap of
            Just LocalPackage
lp -> Map PackageName DepValue -> [PackageName]
forall k a. Map k a -> [k]
M.keys (Package -> Map PackageName DepValue
packageDeps (LocalPackage -> Package
lpPackage LocalPackage
lp)) -- FIXME just Local?
            Maybe LocalPackage
_ -> []
    go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
    go :: PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go PackageName
name = do
        Map PackageName (Maybe (Path Abs File, Target))
cache <- StateT
  (Map PackageName (Maybe (Path Abs File, Target)))
  Identity
  (Map PackageName (Maybe (Path Abs File, Target)))
forall s (m :: * -> *). MonadState s m => m s
get
        case (PackageName
-> Map PackageName (Maybe (Path Abs File, Target))
-> Maybe (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Maybe (Path Abs File, Target))
cache, PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap) of
            (Just (Just (Path Abs File, Target)
_), Maybe LocalPackage
_) -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            (Just Maybe (Path Abs File, Target)
Nothing, Maybe LocalPackage
_) | Bool -> Bool
not Bool
loadAllDeps -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            (Maybe (Maybe (Path Abs File, Target))
_, Just LocalPackage
lp) -> do
                let deps :: [PackageName]
deps = Map PackageName DepValue -> [PackageName]
forall k a. Map k a -> [k]
M.keys (Package -> Map PackageName DepValue
packageDeps (LocalPackage -> Package
lpPackage LocalPackage
lp))
                Bool
shouldLoad <- ([Bool] -> Bool)
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (StateT
   (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
 -> StateT
      (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a b. (a -> b) -> a -> b
$ (PackageName
 -> StateT
      (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go [PackageName]
deps
                if Bool
shouldLoad
                    then do
                        (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name ((Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp, Set NamedComponent -> Target
TargetComps (NamedComponent -> Set NamedComponent
forall a. a -> Set a
S.singleton NamedComponent
CLib))))
                        Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    else do
                        (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name Maybe (Path Abs File, Target)
forall a. Maybe a
Nothing)
                        Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            (Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets :: Map k Target -> Map k Target -> Map k Target
unionTargets = (Target -> Target -> Target)
-> Map k Target -> Map k Target -> Map k Target
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith ((Target -> Target -> Target)
 -> Map k Target -> Map k Target -> Map k Target)
-> (Target -> Target -> Target)
-> Map k Target
-> Map k Target
-> Map k Target
forall a b. (a -> b) -> a -> b
$ \Target
l Target
r ->
    case (Target
l, Target
r) of
        (TargetAll PackageType
PTDependency, Target
_) -> Target
r
        (TargetComps Set NamedComponent
sl, TargetComps Set NamedComponent
sr) -> Set NamedComponent -> Target
TargetComps (Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Ord a => Set a -> Set a -> Set a
S.union Set NamedComponent
sl Set NamedComponent
sr)
        (TargetComps Set NamedComponent
_, TargetAll PackageType
PTProject) -> PackageType -> Target
TargetAll PackageType
PTProject
        (TargetComps Set NamedComponent
_, Target
_) -> Target
l
        (TargetAll PackageType
PTProject, Target
_) -> PackageType -> Target
TargetAll PackageType
PTProject

hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
p Target
t =
    case Target
t of
        TargetComps Set NamedComponent
s -> (NamedComponent -> Bool) -> [NamedComponent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
p (Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
S.toList Set NamedComponent
s)
        TargetAll PackageType
PTProject -> Bool
True
        Target
_ -> Bool
False

-- | Run a command and grab the first line of stdout, dropping
-- stderr's contexts completely.
runGrabFirstLine :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env String
runGrabFirstLine :: String -> [String] -> RIO env String
runGrabFirstLine String
cmd0 [String]
args =
  String
-> [String]
-> (ProcessConfig () () () -> RIO env String)
-> RIO env String
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
cmd0 [String]
args ((ProcessConfig () () () -> RIO env String) -> RIO env String)
-> (ProcessConfig () () () -> RIO env String) -> RIO env String
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> do
    (ByteString
out, ByteString
_err) <- ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc
    String -> RIO env String
forall (m :: * -> *) a. Monad m => a -> m a
return
      (String -> RIO env String) -> String -> RIO env String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack
      (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
TL.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')
      (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
TL.concat
      ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1
      ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines
      (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
lenientDecode ByteString
out