{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

-- | Types and functions related to Stack's @ghci@ and @repl@ commands.

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

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.Foldable ( foldl )
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
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 ((</>), parent, parseRelFile )
import           Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
import           Path.IO
                   ( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir )
import           RIO.Process
                   ( HasProcessContext, exec, proc, readProcess_
                   , withWorkingDir
                   )
import           Stack.Build ( buildLocalTargets )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source
                   ( getLocalFlags, localDependencies, projectLocalPackages )
import           Stack.Build.Target ( NeedTargets (..), parseTargets )
import           Stack.Constants
                   ( relDirGhciScript, relDirStackProgName, relFileCabalMacrosH
                   , relFileGhciScript, stackProgName'
                   )
import           Stack.Constants.Config ( ghciDirL, objectInterfaceDirL )
import           Stack.Ghci.Script
                   ( GhciScript, ModuleName, cmdAdd, cmdCdGhc, cmdModule
                   , scriptToLazyByteString
                   )
import           Stack.Package
                   ( PackageDescriptionPair (..), packageFromPackageDescription
                   , readDotBuildinfo, resolvePackageDescription
                   )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Types.Build.Exception
                   ( BuildPrettyException (..), pprintTargetParseErrors )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import           Stack.Types.BuildOpts
                   ( ApplyCLIFlag, BenchmarkOpts (..), BuildOpts (..)
                   , BuildOptsCLI (..), TestOpts (..), defaultBuildOptsCLI
                   )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), HasCompiler (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , shaPathForBytes
                   )
import           Stack.Types.EnvSettings ( defaultEnvSettings )
import           Stack.Types.NamedComponent
                   ( NamedComponent (..), isCLib, renderPkgComponent )
import           Stack.Types.Package
                   ( BuildInfoOpts (..), InstallMap, InstalledMap
                   , LocalPackage (..), Package (..), PackageConfig (..)
                   , PackageLibraries (..), dotCabalCFilePath, dotCabalGetPath
                   , dotCabalMainPath, getPackageOpts
                   )
import           Stack.Types.PackageFile ( getPackageFiles )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner, Runner )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), GlobalPackage
                   , PackageType (..), ProjectPackage (..), SMActual (..)
                   , SMTargets (..), SMWanted (..), SourceMap (..), Target (..)
                   )
import           System.IO ( putStrLn )
import           System.Permissions ( setScriptPerms )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Ghci" module.

data GhciException
  = InvalidPackageOption String
  | LoadingDuplicateModules
  | MissingFileTarget String
  | Can'tSpecifyFilesAndTargets
  | Can'tSpecifyFilesAndMainIs
  deriving (Int -> GhciException -> ShowS
[GhciException] -> ShowS
GhciException -> String
(Int -> GhciException -> ShowS)
-> (GhciException -> String)
-> ([GhciException] -> ShowS)
-> Show GhciException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciException -> ShowS
showsPrec :: Int -> GhciException -> ShowS
$cshow :: GhciException -> String
show :: GhciException -> String
$cshowList :: [GhciException] -> ShowS
showList :: [GhciException] -> ShowS
Show, Typeable)

instance Exception GhciException where
  displayException :: GhciException -> String
displayException (InvalidPackageOption String
name) =
    String
"Error: [S-6716]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Failed to parse '--package' option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  displayException GhciException
LoadingDuplicateModules = [String] -> String
unlines
    [ String
"Error: [S-9632]"
    , 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)."
    ]
  displayException (MissingFileTarget String
name) =
    String
"Error: [S-3600]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot find file target " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  displayException GhciException
Can'tSpecifyFilesAndTargets =
    String
"Error: [S-9906]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and package targets."
  displayException GhciException
Can'tSpecifyFilesAndMainIs =
    String
"Error: [S-5188]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and '--main-is' \
       \flag."

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

-- "Stack.Ghci" module.

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

instance Pretty GhciPrettyException where
  pretty :: GhciPrettyException -> StyleDoc
pretty (GhciTargetParseException [StyleDoc]
errs) =
       StyleDoc
"[S-6948]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Note that to specify options to be passed to GHCi, use the"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--ghci-options"
         , StyleDoc
"option."
         ]

instance Exception GhciPrettyException

-- | Typre respresenting command line options for the @stack ghci@ and

-- @stack repl@ commands.

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
$cshowsPrec :: Int -> GhciOpts -> ShowS
showsPrec :: Int -> GhciOpts -> ShowS
$cshow :: GhciOpts -> String
show :: GhciOpts -> String
$cshowList :: [GhciOpts] -> ShowS
showList :: [GhciOpts] -> ShowS
Show

-- | Type representing information required 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
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshow :: GhciPkgInfo -> String
show :: GhciPkgInfo -> String
$cshowList :: [GhciPkgInfo] -> ShowS
showList :: [GhciPkgInfo] -> ShowS
Show

-- | Type representing loaded package description and related information.

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)

-- | Function underlying the @stack ghci@ and @stack repl@ commands. Run GHCi in

-- the context of a project.

ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd GhciOpts
ghciOpts =
  let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        -- using only additional packages, targets then get overridden in `ghci`

        { boptsCLITargets :: [Text]
boptsCLITargets = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (GhciOpts -> [String]
ghciAdditionalPackages  GhciOpts
ghciOpts)
        , boptsCLIInitialBuildSteps :: Bool
boptsCLIInitialBuildSteps = Bool
True
        , boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags GhciOpts
ghciOpts
        , boptsCLIGhcOptions :: [Text]
boptsCLIGhcOptions = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (GhciOpts -> [String]
ghciGhcOptions GhciOpts
ghciOpts)
        }
  in  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
        BuildOpts
bopts <- Getting BuildOpts EnvConfig BuildOpts -> RIO EnvConfig BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts EnvConfig BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL
        -- override env so running of tests and benchmarks is disabled

        let boptsLocal :: BuildOpts
boptsLocal = BuildOpts
bopts
              { boptsTestOpts :: TestOpts
boptsTestOpts = (BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts) { toDisableRun :: Bool
toDisableRun = Bool
True }
              , boptsBenchmarkOpts :: BenchmarkOpts
boptsBenchmarkOpts =
                  (BuildOpts -> BenchmarkOpts
boptsBenchmarkOpts BuildOpts
bopts) { beoDisableRun :: Bool
beoDisableRun = Bool
True }
              }
        (EnvConfig -> EnvConfig) -> RIO EnvConfig () -> RIO EnvConfig ()
forall a.
(EnvConfig -> EnvConfig) -> RIO EnvConfig a -> RIO EnvConfig a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter EnvConfig EnvConfig BuildOpts BuildOpts
-> BuildOpts -> EnvConfig -> EnvConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter EnvConfig EnvConfig BuildOpts BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL BuildOpts
boptsLocal) (GhciOpts -> RIO EnvConfig ()
forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
ghciOpts)

-- | 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 :: forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci opts :: GhciOpts
opts@GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciTargets :: GhciOpts -> [Text]
ghciArgs :: GhciOpts -> [String]
ghciGhcOptions :: GhciOpts -> [String]
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: GhciOpts -> Maybe String
ghciNoLoadModules :: GhciOpts -> Bool
ghciAdditionalPackages :: GhciOpts -> [String]
ghciMainIs :: GhciOpts -> Maybe Text
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciNoBuild :: GhciOpts -> Bool
ghciOnlyMain :: GhciOpts -> Bool
ghciTargets :: [Text]
ghciArgs :: [String]
ghciGhcOptions :: [String]
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: Maybe String
ghciNoLoadModules :: Bool
ghciAdditionalPackages :: [String]
ghciMainIs :: Maybe Text
ghciLoadLocalDeps :: Bool
ghciSkipIntermediate :: Bool
ghciHidePackages :: Maybe Bool
ghciNoBuild :: Bool
ghciOnlyMain :: Bool
..} = 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
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
        { 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Map PackageName Target
_ -> GhciException -> RIO env ()
forall e a. Exception e => e -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
Lens' env BuildOpts
buildOptsL
  Maybe (Path Abs File)
mainFile <- if Bool
ghciNoLoadModules
    then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a b. (a -> b) -> Maybe a -> Maybe b
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, HasTerm 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 a. Set a -> [a]
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 a b. (a -> b) -> Maybe a -> Maybe b
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. HasTerm 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 :: forall env.
HasEnvConfig env =>
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])
L.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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> 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 <- String -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
String -> m (Maybe (Path Abs File))
forgivingResolveFile' String
fp
        case Maybe (Path Abs File)
mpath of
          Maybe (Path Abs File)
Nothing -> GhciException -> RIO env (Path Abs File)
forall e a. Exception e => e -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
      Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([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
-> (PrettyException -> RIO env SMTargets) -> RIO env SMTargets
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
          case SomeException -> Maybe BuildPrettyException
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe BuildPrettyException)
-> SomeException -> Maybe BuildPrettyException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex of
            Just (TargetParseException [StyleDoc]
xs) ->
              GhciPrettyException -> RIO env SMTargets
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (GhciPrettyException -> RIO env SMTargets)
-> GhciPrettyException -> RIO env SMTargets
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
            Maybe BuildPrettyException
_ -> PrettyException -> RIO env SMTargets
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
pex
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> 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 e a. Exception e => e -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env.
HasEnvConfig env =>
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: 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]
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
-> 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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]
L.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 a. Eq a => a -> [a] -> 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 ()
prettyWarnL
          [ String -> StyleDoc
flow String
"Couldn't find a component for file target"
          , 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
"."
          , String -> StyleDoc
flow String
"This means that the correct GHC options might not be used. \
                 \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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ()
prettyInfoL
          [ String -> StyleDoc
flow String
"Using configuration for"
          , (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x
          , String -> StyleDoc
flow String
"to load"
          , 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Multiple components contain file target"
               , 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
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate 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] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Guessing the first one,"
               , (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 b a. (b -> a -> b) -> b -> [a] -> b
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env.
HasEnvConfig env =>
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)
ghciTargets :: GhciOpts -> [Text]
ghciArgs :: GhciOpts -> [String]
ghciGhcOptions :: GhciOpts -> [String]
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: GhciOpts -> Maybe String
ghciNoLoadModules :: GhciOpts -> Bool
ghciAdditionalPackages :: GhciOpts -> [String]
ghciMainIs :: GhciOpts -> Maybe Text
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciNoBuild :: GhciOpts -> Bool
ghciOnlyMain :: GhciOpts -> Bool
ghciTargets :: [Text]
ghciArgs :: [String]
ghciGhcOptions :: [String]
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: Maybe String
ghciNoLoadModules :: Bool
ghciAdditionalPackages :: [String]
ghciMainIs :: Maybe Text
ghciLoadLocalDeps :: Bool
ghciSkipIntermediate :: Bool
ghciHidePackages :: Maybe Bool
ghciNoBuild :: Bool
ghciOnlyMain :: Bool
..} 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
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 a. [a] -> 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
    else do
      let extraList' :: [StyleDoc]
extraList' =
            ((PackageName, (Path Abs File, Target)) -> StyleDoc)
-> [(PackageName, (Path Abs File, Target))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, (Path Abs File, Target)) -> String)
-> (PackageName, (Path Abs File, Target))
-> StyleDoc
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 :: [StyleDoc]
          extraList :: [StyleDoc]
extraList = Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
      if Bool
ghciLoadLocalDeps
        then 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] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                [ String -> StyleDoc
flow String
"The following libraries will also be loaded into \
                       \GHCi because they are local dependencies of your \
                       \targets, and you specified"
                , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--load-local-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                ]
            [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
        else 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] -> StyleDoc
fillSep
               ( String -> StyleDoc
flow String
"The following libraries will also be loaded into \
                      \GHCi because they are intermediate dependencies of \
                      \your targets:"
               StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
               )
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"(Use"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--skip-intermediate-deps"
               , String -> StyleDoc
flow String
"to omit these.)"
               ]
      [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(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 :: forall env. 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([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 :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciTargets :: GhciOpts -> [Text]
ghciArgs :: GhciOpts -> [String]
ghciGhcOptions :: GhciOpts -> [String]
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: GhciOpts -> Maybe String
ghciNoLoadModules :: GhciOpts -> Bool
ghciAdditionalPackages :: GhciOpts -> [String]
ghciMainIs :: GhciOpts -> Maybe Text
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciNoBuild :: GhciOpts -> Bool
ghciOnlyMain :: GhciOpts -> Bool
ghciTargets :: [Text]
ghciArgs :: [String]
ghciGhcOptions :: [String]
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: Maybe String
ghciNoLoadModules :: Bool
ghciAdditionalPackages :: [String]
ghciMainIs :: Maybe Text
ghciLoadLocalDeps :: Bool
ghciSkipIntermediate :: Bool
ghciHidePackages :: Maybe Bool
ghciNoBuild :: Bool
ghciOnlyMain :: Bool
..} [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'.

  case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
targets of
    -- only new local targets could appear here

    Just NonEmpty Text
nonEmptyTargets | Bool -> Bool
not Bool
ghciNoBuild -> do
      Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
      case Either SomeException ()
eres of
        Right () -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left SomeException
err -> do
          case SomeException -> Maybe PrettyException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
            Just (PrettyException e
prettyErr) -> 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
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
            Maybe PrettyException
Nothing -> 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 e. Exception e => e -> String
displayException 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"
    Maybe (NonEmpty Text)
_ ->
      () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages :: forall (m :: * -> *). MonadThrow m => [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 a. Maybe a -> Maybe a -> Maybe a
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 e a. Exception e => e -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageName
mres

runGhci ::
     HasEnvConfig env
  => GhciOpts
  -> [(PackageName, (Path Abs File, Target))]
  -> Maybe (Path Abs File)
  -> [GhciPkgInfo]
  -> [Path Abs File]
  -> [PackageName]
  -> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
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)
ghciTargets :: GhciOpts -> [Text]
ghciArgs :: GhciOpts -> [String]
ghciGhcOptions :: GhciOpts -> [String]
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: GhciOpts -> Maybe String
ghciNoLoadModules :: GhciOpts -> Bool
ghciAdditionalPackages :: GhciOpts -> [String]
ghciMainIs :: GhciOpts -> Maybe Text
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciNoBuild :: GhciOpts -> Bool
ghciOnlyMain :: GhciOpts -> Bool
ghciTargets :: [Text]
ghciArgs :: [String]
ghciGhcOptions :: [String]
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcCommand :: Maybe String
ghciNoLoadModules :: Bool
ghciAdditionalPackages :: [String]
ghciMainIs :: Maybe Text
ghciLoadLocalDeps :: Bool
ghciSkipIntermediate :: Bool
ghciHidePackages :: Maybe Bool
ghciNoBuild :: Bool
ghciOnlyMain :: Bool
..} [(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
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall a. [a] -> 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 a. [a] -> 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])
L.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 m. Monoid m => Map ApplyGhcOptions m -> m
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
L.isPrefixOf String
"-O" String
x Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall a. Eq a => a -> [a] -> 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 a. [a] -> 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
$
      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
fillSep
             ( String -> StyleDoc
flow String
"The following GHC options are incompatible with GHCi and \
                    \have not been passed to it:"
             StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
                 ((String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
forall a. IsString a => String -> a
fromString ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts) :: [StyleDoc])
             )
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    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 ]
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      ( String -> StyleDoc
flow String
"Configuring GHCi with the following packages:"
      StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
          ((GhciPkgInfo -> StyleDoc) -> [GhciPkgInfo] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (GhciPkgInfo -> String) -> GhciPkgInfo -> StyleDoc
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 :: [StyleDoc])
      )
    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
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 a. IO a -> RIO env a
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
            RIO env b -> RIO env b
forall {a}. RIO env a -> RIO env a
withPackageWorkingDir (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ 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] -> [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 a. [a] -> 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] -> [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)
        withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
            case [GhciPkgInfo]
pkgs of
              [GhciPkgInfo
pkg] -> String -> RIO env a -> RIO env a
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath (Path Abs Dir -> String) -> Path Abs Dir -> String
forall a b. (a -> b) -> a -> b
$ GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
              [GhciPkgInfo]
_ -> RIO env a -> RIO env a
forall a. a -> a
id
        -- 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 a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
`L.isPrefixOf` String
output
                [GhciPkgInfo]
_ -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    -- Since usage of 'exec' does not pure, 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 <- XdgDirectory -> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgCache (Maybe (Path Rel Dir) -> RIO env (Path Abs Dir))
-> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
      Path Rel Dir -> Maybe (Path Rel Dir)
forall a. a -> Maybe a
Just (Path Rel Dir
relDirStackProgName Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGhciScript)
    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 {b}. [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 {b}. [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 :: forall env.
HasTerm env =>
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 a b. (a -> b) -> RIO env a -> RIO env b
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 a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
  [ByteString]
files <- IO [ByteString] -> RIO env [ByteString]
forall a. IO a -> RIO env a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
files then [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else do
    Path Abs File
out <- IO (Path Abs File) -> RIO env (Path Abs File)
forall a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [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 :: forall (m :: * -> *).
MonadIO m =>
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 a. IO a -> m a
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 :: * -> *). Monad m => String -> m ()
setScriptPerms String
scriptFilePath
  [String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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, HasTerm env)
  => BuildOpts
  -> Maybe (Map PackageName Target)
  -> [(PackageName, (Path Abs File, Target))]
  -> [GhciPkgInfo]
  -> RIO env (Maybe (Path Abs File))
figureOutMainFile :: forall env.
(HasRunner env, HasTerm 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))]
targets0 [GhciPkgInfo]
packages =
    case [(PackageName, NamedComponent, Path Abs File)]
candidates of
      [] -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
      [c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> 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] -> StyleDoc
fillSep
               [ StyleDoc
"Using"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
               , StyleDoc
"module:"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate (PackageName, NamedComponent, Path Abs File)
c
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
        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
fillSep
               [ StyleDoc
"The"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
               , String -> StyleDoc
flow String
"module to load is ambiguous. Candidates are:"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line (((PackageName, NamedComponent, Path Abs File) -> StyleDoc)
-> [(PackageName, NamedComponent, Path Abs File)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates))
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You can specify which one to pick by:"
          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
               [ [StyleDoc] -> StyleDoc
fillSep
                   [ String -> StyleDoc
flow String
"Specifying targets to"
                   , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack ghci")
                   , StyleDoc
"e.g."
                   , Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
                                     [ String -> StyleDoc
flow String
"stack ghci"
                                     , (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {a} {c}.
(Semigroup a, IsString a) =>
(PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate
                                     ]
                                 ) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                   ]
               , [StyleDoc] -> StyleDoc
fillSep
                   [ String -> StyleDoc
flow String
"Specifying what the"
                   , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
                   , String -> StyleDoc
flow String
"is e.g."
                   , Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
                                     [ String -> StyleDoc
flow String
"stack ghci"
                                     , (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {c}. (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate
                                     ]
                                 ) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                   ]
                , String -> StyleDoc
flow
                    (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$  String
"Choosing from the candidate above [1.."
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]."
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall a. IO a -> RIO env a
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 a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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) -> StyleDoc
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName, NamedComponent
namedComponent, Path Abs File
mainIs) =
    let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex =
          String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ([(PackageName, NamedComponent, Path Abs File)] -> String)
-> [(PackageName, NamedComponent, Path Abs File)]
-> StyleDoc
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
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
        pkgNameText :: StyleDoc
pkgNameText = String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkgName
    in  Int -> StyleDoc -> StyleDoc
hang Int
4
          (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$  Int -> StyleDoc -> StyleDoc
fill Int
4 ( [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
".")
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"Package"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgNameText StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
               , StyleDoc
"component"
        --       This is the format that can be directly copy-pasted as

        --       an argument to `stack ghci`.

               , Style -> StyleDoc -> StyleDoc
style
                   Style
PkgComponent
                   (  StyleDoc
pkgNameText
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
namedComponent
                   )
                 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
               , StyleDoc
"with"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"main-is"
               , StyleDoc
"file:"
               , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
mainIs StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
  candidateIndices :: [Int]
candidateIndices = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> 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 a. [a] -> 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
L.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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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. HasCallStack => [a] -> Int -> a
L.!! 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> a
renderComp NamedComponent
c =
    case NamedComponent
c of
      NamedComponent
CLib -> a
"lib"
      CInternalLib Text
name -> a
"internal-lib:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
      CExe Text
name -> a
"exe:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
      CTest Text
name -> a
"test:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString ( Text -> String
T.unpack Text
name)
      CBench Text
name -> a
"bench:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> String -> a
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
  sampleTargetArg :: (PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName
pkg, NamedComponent
comp, c
_) =
       String -> a
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg)
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
":"
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> a
forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
comp
  sampleMainIsArg :: (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName
pkg, NamedComponent
comp, c
_) =
    [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
"--main-is"
      , String -> StyleDoc
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
comp
      ]

loadGhciPkgDescs ::
     HasEnvConfig env
  => BuildOptsCLI
  -> [(PackageName, (Path Abs File, Target))]
  -> RIO env [GhciPkgDesc]
loadGhciPkgDescs :: forall env.
HasEnvConfig env =>
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 :: forall env.
HasEnvConfig env =>
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
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
SimpleGetter env ActualCompiler
actualCompilerVersionL
  let SourceMap{Map PackageName GlobalPackage
Map PackageName ProjectPackage
Map PackageName DepPackage
ActualCompiler
SMTargets
smCompiler :: SourceMap -> ActualCompiler
smProject :: SourceMap -> Map PackageName ProjectPackage
smDeps :: SourceMap -> Map PackageName DepPackage
smGlobal :: SourceMap -> Map PackageName GlobalPackage
smTargets :: SMTargets
smCompiler :: ActualCompiler
smProject :: Map PackageName ProjectPackage
smDeps :: Map PackageName DepPackage
smGlobal :: Map PackageName GlobalPackage
smTargets :: SourceMap -> SMTargets
..} = 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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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)
      sourceMapFlags :: Map FlagName Bool
sourceMapFlags =
        Map FlagName Bool
-> (ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage
-> Map FlagName Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map FlagName Bool
forall a. Monoid a => a
mempty (CommonPackage -> Map FlagName Bool
cpFlags (CommonPackage -> Map FlagName Bool)
-> (ProjectPackage -> CommonPackage)
-> ProjectPackage
-> Map FlagName Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon) (Maybe ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage -> Map FlagName Bool
forall a b. (a -> b) -> a -> 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
      config :: PackageConfig
config = 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 Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map FlagName Bool
sourceMapFlags
        , 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
Lens' EnvConfig 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) <-
      Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (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 a. IO a -> RIO env a
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 -> [PackageFlag] -> PackageDescriptionPair -> Package
packageFromPackageDescription PackageConfig
config (GenericPackageDescription -> [PackageFlag]
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env.
HasEnvConfig env =>
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 :: forall env.
HasEnvConfig env =>
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
Lens' env 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
-> 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs =
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GhciPkgInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GhciPkgInfo]
pkgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    -- Cabal flag issues could arise only when there are at least 2 packages

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StyleDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StyleDoc]
cabalFlagIssues) (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
$
           String -> StyleDoc
flow String
"There are Cabal flags for this project which may prevent \
                \GHCi from loading your code properly. In some cases it \
                \can also load some projects which would otherwise fail to \
                \build."
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine [StyleDoc]
cabalFlagIssues)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"To resolve, remove the flag(s) from the Cabal file(s) and \
                \instead put them at the top of the Haskell files."
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ String -> StyleDoc
flow String
"It isn't yet possible to load multiple packages into GHCi in \
             \all cases. For further information, see"
      , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://ghc.haskell.org/trac/ghc/ticket/10827" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
 where
  cabalFlagIssues :: [StyleDoc]
cabalFlagIssues = ((String, [StyleDoc]) -> [StyleDoc])
-> [(String, [StyleDoc])] -> [StyleDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [StyleDoc]) -> [StyleDoc]
mixedFlag
    [ ( String
"-XNoImplicitPrelude"
      , [ String -> StyleDoc
flow String
"-XNoImplicitPrelude will be used, but GHCi will likely fail to \
               \build things which depend on the implicit prelude."
        ]
      )
    , ( String
"-XCPP"
      , [ String -> StyleDoc
flow String
"-XCPP will be used, but it can cause issues with multiline \
               \strings. For further information, see"
        , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      )
    , ( String
"-XNoTraditionalRecordSyntax"
      , [ String -> StyleDoc
flow String
"-XNoTraditionalRecordSyntax will be used, but it break modules \
               \which use record syntax."
        ]
      )
    , ( String
"-XTemplateHaskell"
      , [ String -> StyleDoc
flow String
"-XTemplateHaskell will be used, but it may cause compilation \
               \issues due to different parsing of '$' when there's no space \
               \after it."
        ]
      )
    , ( String
"-XQuasiQuotes"
      , [ String -> StyleDoc
flow String
"-XQuasiQuotes will be used, but it may cause parse failures \
               \due to a different meaning for list comprehension syntax like \
               \[x| ... ]"
          ]
      )
    , ( String
"-XSafe"
      , [ String -> StyleDoc
flow String
"-XSafe will be used, but it will fail to compile unsafe \
               \modules."
        ]
      )
    , ( String
"-XArrows"
      , [ String -> StyleDoc
flow String
"-XArrows will be used, but it will cause non-arrow usages of \
               \proc, (-<), (-<<) to fail"
        ]
      )
    , ( String
"-XOverloadedStrings"
      , [ String -> StyleDoc
flow String
"-XOverloadedStrings will be used, but it can cause type \
               \ambiguity in code not usually compiled with it."
        ]
      )
    , ( String
"-XOverloadedLists"
      , [ String -> StyleDoc
flow String
"-XOverloadedLists will be used, but it can cause type \
               \ambiguity in code not usually compiled with it."
        ]
      )
    , ( String
"-XMonoLocalBinds"
      , [ String -> StyleDoc
flow String
"-XMonoLocalBinds will be used, but it can cause type errors in \
               \code which expects generalized local bindings." ]
      )
    , ( String
"-XTypeFamilies"
      , [ String -> StyleDoc
flow String
"-XTypeFamilies will be used, but it implies -XMonoLocalBinds, \
               \and so can cause type errors in code which expects generalized \
               \local bindings." ]
      )
    , ( String
"-XGADTs"
      , [ String -> StyleDoc
flow String
"-XGADTs will be used, but it implies -XMonoLocalBinds, and so \
               \can cause type errors in code which expects generalized local \
               \bindings." ]
      )
    , ( String
"-XNewQualifiedOperators"
      , [ String -> StyleDoc
flow String
"-XNewQualifiedOperators will be used, but this will break \
               \usages of the old qualified operator syntax." ]
      )
    ]
  mixedFlag :: (String, [StyleDoc]) -> [StyleDoc]
mixedFlag (String
flag, [StyleDoc]
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
    [ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
msgs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++ ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
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)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)]
haveIt, [(PackageName, NamedComponent)]
don'tHaveIt) =
       [ String -> StyleDoc
flow String
"It is specified for:" ]
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
         (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (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) [(PackageName, NamedComponent)]
haveIt :: [StyleDoc])
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ String -> StyleDoc
flow String
"But not for:" ]
    [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
         (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (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) [(PackageName, NamedComponent)]
don'tHaveIt :: [StyleDoc])
  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])
L.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
    ]

-- TODO: Should this also tell the user the filepaths, not just the

-- module name?

checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs =
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> Bool
forall a. [a] -> 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
$
    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
$
         String -> StyleDoc
flow String
"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)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    -- 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) =
       [StyleDoc] -> StyleDoc
fillSep
         [ Style -> StyleDoc -> StyleDoc
style Style
Error (ModuleName -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn)
         , String -> StyleDoc
flow String
"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) =
    [StyleDoc] -> StyleDoc
fillSep
      [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
      , 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
"," (((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 :: 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 = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageName] -> Bool
forall a. [a] -> 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 a. [a] -> 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
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)
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
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 b a. (b -> a -> b) -> b -> [a] -> b
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 b c a. (b -> c) -> (a, b) -> (a, c)
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 a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            (Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets :: forall k. Ord k => 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (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