{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciException] -> ShowS
$cshowList :: [GhciException] -> ShowS
show :: GhciException -> String
$cshow :: GhciException -> String
showsPrec :: Int -> GhciException -> ShowS
$cshowsPrec :: Int -> GhciException -> ShowS
Show, Typeable)

instance Exception GhciException where
  displayException :: GhciException -> String
displayException (InvalidPackageOption String
name) =
    String
"Error: [S-6716]\n"
    forall a. [a] -> [a] -> [a]
++ String
"Failed to parse '--package' option " forall a. [a] -> [a] -> [a]
++ String
name 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"
    forall a. [a] -> [a] -> [a]
++ String
"Cannot find file target " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"."
  displayException GhciException
Can'tSpecifyFilesAndTargets =
    String
"Error: [S-9906]\n"
    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"
    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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciPrettyException] -> ShowS
$cshowList :: [GhciPrettyException] -> ShowS
show :: GhciPrettyException -> String
$cshow :: GhciPrettyException -> String
showsPrec :: Int -> GhciPrettyException -> ShowS
$cshowsPrec :: Int -> GhciPrettyException -> ShowS
Show, Typeable)

instance Pretty GhciPrettyException where
  pretty :: GhciPrettyException -> StyleDoc
pretty (GhciTargetParseException [StyleDoc]
errs) =
       StyleDoc
"[S-6948]"
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciOpts] -> ShowS
$cshowList :: [GhciOpts] -> ShowS
show :: GhciOpts -> String
$cshow :: GhciOpts -> String
showsPrec :: Int -> GhciOpts -> ShowS
$cshowsPrec :: Int -> GhciOpts -> ShowS
Show

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciPkgInfo] -> ShowS
$cshowList :: [GhciPkgInfo] -> ShowS
show :: GhciPkgInfo -> String
$cshow :: GhciPkgInfo -> String
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
Show

-- | 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 = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith 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 = 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 = forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (GhciOpts -> [String]
ghciGhcOptions GhciOpts
ghciOpts)
        }
  in  forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI forall a b. (a -> b) -> a -> b
$ do
        BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s 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 }
              }
        forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall s. HasConfig s => Lens' s BuildOpts
buildOptsL BuildOpts
boptsLocal) (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)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} = do
  let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        { boptsCLITargets :: [Text]
boptsCLITargets = []
        , boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags
        }
  SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
  InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
  [LocalPackage]
depLocals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
  let localMap :: Map PackageName LocalPackage
localMap =
        forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Package -> PackageName
packageName forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals 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 <- 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 <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
packageTargets, forall a. Maybe a
Nothing)
    Left [Path Abs File]
rawFileTargets -> do
      case Maybe (Map PackageName Target)
mainIsTargets of
        Maybe (Map PackageName Target)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Map PackageName Target
_ -> 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) <- 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, 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 <- 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 <- forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
  -- Check if additional package arguments are sensible.

  [PackageName]
addPkgs <- forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
ghciAdditionalPackages
  -- Load package descriptions.

  [GhciPkgDesc]
pkgDescs <- 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
  Maybe (Path Abs File)
mainFile <- if Bool
ghciNoLoadModules
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
      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 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps]
  -- Build required dependencies and setup local packages.

  forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
opts forall a b. (a -> b) -> a -> b
$
    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
  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 <- forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
  forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs
  -- Finally, do the invocation of ghci

  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
    (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a b. (a, b) -> b
snd Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets)
    ([PackageName]
nonLocalTargets 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) =
        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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
normalTargetsRaw
    then do
      [Path Abs File]
fileTargets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fileTargetsRaw 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 <- 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 -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> GhciException
MissingFileTarget String
fp)
          Just Path Abs File
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
          case forall e. Exception e => SomeException -> Maybe e
fromException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException e
ex of
            Just (TargetParseException [StyleDoc]
xs) ->
              forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
            Maybe BuildPrettyException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
pex
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Text
mtarget forall a b. (a -> b) -> a -> b
$ \Text
target -> do
  let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text
target] }
  SMTargets
targets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
locals 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)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage
lp, forall a b k. (a -> b) -> Map k a -> Map k b
M.map (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 =
        forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
fp -> (Path Abs File
fp, ) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(LocalPackage
lp, Map NamedComponent [Path Abs File]
files) -> forall a b. (a -> b) -> [a] -> [b]
map ((Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp), ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                                                   (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Path Abs File
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents forall a b. (a -> b) -> a -> b
$ \(Path Abs File
fp, [(PackageName, NamedComponent)]
xs) ->
    case [(PackageName, NamedComponent)]
xs of
      [] -> do
        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"
          , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp 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."
          ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Path Abs File
fp
      [(PackageName, NamedComponent)
x] -> do
        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"
          , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
          ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
      ((PackageName, NamedComponent)
x:[(PackageName, NamedComponent)]
_) -> do
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Multiple components contain file target"
               , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
               , [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent [(PackageName, NamedComponent)]
xs)
               ]
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          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 forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results
      targetMap :: Map PackageName Target
targetMap =
          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
_, (PackageName
name, NamedComponent
comp)) -> forall k a. k -> a -> Map k a
M.singleton PackageName
name (Set NamedComponent -> Target
TargetComps (forall a. a -> Set a
S.singleton NamedComponent
comp)))
              [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
      infoMap :: Map PackageName [Path Abs File]
infoMap =
          forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)) forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
fp, (PackageName
name, NamedComponent
_)) -> forall k a. k -> a -> Map k a
M.singleton PackageName
name [Path Abs File
fp])
              [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
  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)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
  -- Use the 'mainIsTargets' as normal targets, for CLI concision. See

  -- #1845. This is a little subtle - we need to do the target parsing

  -- independently in order to handle the case where no targets are

  -- specified.

  let targets :: Map PackageName Target
targets = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PackageName Target
targets0 (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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName ProjectPackage
packages) forall a b. (a -> b) -> a -> b
$
        \(PackageName
name, ProjectPackage
pp) ->
              case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName Target
targets of
                Just Target
simpleTargets -> forall a. a -> Maybe a
Just (PackageName
name, (ProjectPackage -> Path Abs File
ppCabalFP ProjectPackage
pp, Target
simpleTargets))
                Maybe Target
Nothing -> 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
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
    else do
      let extraList' :: [StyleDoc]
extraList' =
            forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps :: [StyleDoc]
          extraList :: [StyleDoc]
extraList = forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
      if Bool
ghciLoadLocalDeps
        then forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
          [StyleDoc] -> StyleDoc
fillSep 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" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                ]
            forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
        else forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo 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:"
               forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
               )
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          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.)"
               ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
isNonLocal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (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)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [Text]
localTargets = do
  let targets :: [Text]
targets = [Text]
localTargets forall a. [a] -> [a] -> [a]
++ 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 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 <- forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
      case Either SomeException ()
eres of
        Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left SomeException
err -> do
          case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
            Just (PrettyException e
prettyErr) -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
            Maybe PrettyException
Nothing -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (forall e. Exception e => e -> String
displayException SomeException
err)
          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)
_ ->
      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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgs forall a b. (a -> b) -> a -> b
$ \String
name -> do
  let mres :: Maybe PackageName
mres = (PackageIdentifier -> PackageName
pkgName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
name)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing String
name
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> GhciException
InvalidPackageOption String
name) 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)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [(PackageName, (Path Abs File, Target))]
targets Maybe (Path Abs File)
mainFile [GhciPkgInfo]
pkgs [Path Abs File]
extraFiles [PackageName]
exposePackages = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let pkgopts :: [String]
pkgopts = [String]
hidePkgOpts forall a. [a] -> [a] -> [a]
++ [String]
genOpts forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
        shouldHidePackages :: Bool
shouldHidePackages =
          forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> 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"] 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else []) forall a. [a] -> [a] -> [a]
++
              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 forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioPackageFlags BuildInfoOpts
bio
            | Bool
otherwise = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio
        genOpts :: [String]
genOpts = forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
oneWordOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs)
        ([String]
omittedOpts, [String]
ghcOpts) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition String -> Bool
badForGhci forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
bioOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
              ( forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config) -- include everything, locals, and targets

             forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs
              )
        getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg = 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 =
            forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"-O" String
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) forall a b. (a -> b) -> a -> b
$
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn 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:"
             forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False
                 (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => String -> a
fromString (forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts) :: [StyleDoc])
             )
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    Path Abs Dir
oiDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
    let odir :: [String]
odir =
            [ String
"-odir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
            , String
"-hidir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir ]
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      ( String -> StyleDoc
flow String
"Configuring GHCi with the following packages:"
      forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False
          (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs :: [StyleDoc])
      )
    String
compilerExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompilerforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to forall b t. Path b t -> String
toFilePath
    let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
            ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
            forall {a}. RIO env a -> RIO env a
withPackageWorkingDir forall a b. (a -> b) -> a -> b
$ forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
                 (forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand)
                 ((String
"--interactive" : ) 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then forall a. a -> a
id else (String
"-i" : )) forall a b. (a -> b) -> a -> b
$
                  [String]
odir forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts forall a. Semigroup a => a -> a -> a
<> [String]
extras forall a. Semigroup a => a -> a -> a
<> [String]
ghciGhcOptions forall a. Semigroup a => a -> a -> a
<> [String]
ghciArgs)
        withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
            case [GhciPkgInfo]
pkgs of
              [GhciPkgInfo
pkg] -> forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
              [GhciPkgInfo]
_ -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
                    String
output <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
                            forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine (forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand) [String
"--version"]
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Intero" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
output
                [GhciPkgInfo]
_ -> 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 <- forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgCache forall a b. (a -> b) -> a -> b
$
      forall a. a -> Maybe a
Just (Path Rel Dir
relDirStackProgName forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGhciScript)
    Path Abs Dir
ghciDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
    [String]
macrosOptions <- forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
    if Bool
ghciNoLoadModules
        then forall {b}. [String] -> RIO env b
execGhci [String]
macrosOptions
        else do
            forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
            Bool
isIntero <- RIO env Bool
checkIsIntero
            [String]
scriptOptions <- 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)
            forall {b}. [String] -> RIO env b
execGhci ([String]
macrosOptions 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgInfo]
pkgs forall a b. (a -> b) -> a -> b
$ \GhciPkgInfo
pkg -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts GhciPkgInfo
pkg) 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
cabalMacros
      if Bool
exists
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
cabalMacros
        else do
          forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL [StyleDoc
"Didn't find expected autogen file:", forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalMacros]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  [ByteString]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ByteString
S8.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
fps
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
files then forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else do
    Path Abs File
out <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$
      [ByteString] -> ByteString
S8.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Semigroup a => a -> a -> a
<> ByteString
"\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") [ByteString]
files
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-optP-include", String
"-optP" forall a. Semigroup a => a -> a -> a
<> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$
    ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ GhciScript -> ByteString
scriptToLazyByteString GhciScript
script
  let scriptFilePath :: String
scriptFilePath = forall b t. Path b t -> String
toFilePath Path Abs File
scriptPath
  forall (m :: * -> *). MonadIO m => String -> m ()
setScriptPerms String
scriptFilePath
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-ghci-script=" 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 <- 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 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 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
  Bool
alreadyExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
outFile
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outDir
    forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outFile forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
contents
  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])
_ -> forall a. Monoid a => a
mempty
      addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ModuleName]
allModules forall a. [a] -> [a] -> [a]
++ 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 -> [forall a b. b -> Either a b
Right Path Abs File
path]
          Maybe (Path Abs File)
_ -> []
      modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
      allModules :: [ModuleName]
allModules = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> ModuleMap
ghciPkgModules) [GhciPkgInfo]
pkgs
  case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
    [] ->
      if Bool
onlyMain
        then GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> if forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList forall {a}. [Either a (Path Abs File)]
addMain) else forall a. Monoid a => a
mempty
        else GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
addPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
    [Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList 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
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      [c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"Using"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
               , StyleDoc
"module:"
               ]
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          forall a. Semigroup a => a -> a -> a
<> (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate (PackageName, NamedComponent, Path Abs File)
c
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
fp)
      (PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn 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:"
               ]
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates))
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You can specify which one to pick by:"
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          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"
                                     , forall {a} {c}.
(Semigroup a, IsString a) =>
(PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate
                                     ]
                                 ) 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"
                                     , forall {c}. (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate
                                     ]
                                 ) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                   ]
                , String -> StyleDoc
flow
                    forall a b. (a -> b) -> a -> b
$  String
"Choosing from the candidate above [1.."
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates)
                    forall a. Semigroup a => a -> a -> a
<> String
"]."
               ]
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
 where
  targets :: Map PackageName Target
targets = forall a. a -> Maybe a -> a
fromMaybe (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ 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 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) <-
            forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
            forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k 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
        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 =
          forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
        pkgNameText :: StyleDoc
pkgNameText = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkgName
    in  Int -> StyleDoc -> StyleDoc
hang Int
4
          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 forall a. Semigroup a => a -> a -> a
<> StyleDoc
".")
          forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"Package"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgNameText 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
                   forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                   forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
namedComponent
                   )
                 forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
               , StyleDoc
"with"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"main-is"
               , StyleDoc
"file:"
               , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
mainIs forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
  candidateIndices :: [Int]
candidateIndices = forall a. Int -> [a] -> [a]
take (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 <- forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
    let selected :: Int
selected = forall a. a -> Maybe a -> a
fromMaybe
                    ((forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
                    (forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
    case 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
""
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just Int
op -> do
        let (PackageName
_,NamedComponent
_,Path Abs File
fp) = [(PackageName, NamedComponent, Path Abs File)]
candidates forall a. [a] -> Int -> a
L.!! Int
op
        String -> IO ()
putStrLn
          (String
"Loading main module from candidate " forall a. Semigroup a => a -> a -> a
<>
          forall a. Show a => a -> String
show (Int
op forall a. Num a => a -> a -> a
+ Int
1) forall a. Semigroup a => a -> a -> a
<> String
", --main-is " forall a. Semigroup a => a -> a -> a
<>
          forall b t. Path b t -> String
toFilePath Path Abs File
fp)
        String -> IO ()
putStrLn String
""
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
      CExe Text
name -> a
"exe:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
      CTest Text
name -> a
"test:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString ( Text -> String
T.unpack Text
name)
      CBench Text
name -> a
"bench:" forall a. Semigroup a => a -> a -> 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
_) =
       forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg)
    forall a. Semigroup a => a -> a -> a
<> a
":"
    forall a. Semigroup a => a -> a -> 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"
      , forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> 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 =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PackageName, (Path Abs File, Target))]
localTargets forall a b. (a -> b) -> a -> b
$ \(PackageName
name, (Path Abs File
cabalfp, Target
target)) ->
    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
  ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  let SourceMap{Map PackageName GlobalPackage
Map PackageName ProjectPackage
Map PackageName DepPackage
ActualCompiler
SMTargets
smTargets :: SourceMap -> SMTargets
smGlobal :: Map PackageName GlobalPackage
smDeps :: Map PackageName DepPackage
smProject :: Map PackageName ProjectPackage
smCompiler :: ActualCompiler
smTargets :: SMTargets
smGlobal :: SourceMap -> Map PackageName GlobalPackage
smDeps :: SourceMap -> Map PackageName DepPackage
smProject :: SourceMap -> Map PackageName ProjectPackage
smCompiler :: SourceMap -> ActualCompiler
..} = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
econfig
      -- Currently this source map is being build with

      -- the default targets

      sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
        (CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
      sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
        (CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
      sourceMapFlags :: Map FlagName Bool
sourceMapFlags =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (CommonPackage -> Map FlagName Bool
cpFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon) forall a b. (a -> b) -> a -> b
$ 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 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 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL EnvConfig
econfig
        }
  -- TODO we've already parsed this information, otherwise we

  -- wouldn't have figured out the cabalfp already. In the future:

  -- retain that GenericPackageDescription in the relevant data

  -- structures to avoid reparsing.

  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
_cabalfp) <-
      forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
  GenericPackageDescription
gpkgdesc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++ String
".buildinfo")
  Bool
hasDotBuildinfo <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp 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 = forall a. a -> Maybe a
Just (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
        | Bool
otherwise = forall a. Maybe a
Nothing
  Maybe HookedBuildInfo
mbuildinfo <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Path Abs File)
mbuildinfofp 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) forall a b. (a -> b) -> a -> b
$
        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
  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]
_) <- 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)
        ]
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgDesc]
localTargets forall a b. (a -> b) -> a -> b
$ \GhciPkgDesc
pkgDesc ->
    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
  let pkg :: Package
pkg = GhciPkgDesc -> Package
ghciDescPkg GhciPkgDesc
pkgDesc
      cabalfp :: Path Abs File
cabalfp = GhciPkgDesc -> Path Abs File
ghciDescCabalFp GhciPkgDesc
pkgDesc
      target :: Target
target = GhciPkgDesc -> Target
ghciDescTarget GhciPkgDesc
pkgDesc
      name :: PackageName
name = Package -> PackageName
packageName Package
pkg
  (Map NamedComponent (Map ModuleName (Path Abs File))
mods,Map NamedComponent [DotCabalPath]
files,Map NamedComponent BuildInfoOpts
opts) <- GetPackageOpts
-> 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 = forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
      filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgInfo
    { ghciPkgName :: PackageName
ghciPkgName = PackageName
name
    , ghciPkgOpts :: [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts = forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
    , ghciPkgDir :: Path Abs Dir
ghciPkgDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp
    , ghciPkgModules :: ModuleMap
ghciPkgModules = [ModuleMap] -> ModuleMap
unionModuleMaps forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (\(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\Path Abs File
fp -> forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp (forall a. a -> Set a
S.singleton (Package -> PackageName
packageName Package
pkg, NamedComponent
comp))) Map ModuleName (Path Abs File)
mp)
          (forall k a. Map k a -> [(k, a)]
M.toList (forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
    , ghciPkgMainIs :: Map NamedComponent [Path Abs File]
ghciPkgMainIs = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
    , ghciPkgCFiles :: [Path Abs File]
ghciPkgCFiles = forall a. Monoid a => [a] -> a
mconcat (forall k a. Map k a -> [a]
M.elems (forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted (forall a b k. (a -> b) -> Map k a -> Map k b
M.map (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$
  (case Package -> PackageLibraries
packageLibraries Package
pkg of
    PackageLibraries
NoLibraries -> []
    HasLibraries Set Text
names -> NamedComponent
CLib forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList Set Text
names)) forall a. [a] -> [a] -> [a]
++
  forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageExes Package
pkg)) forall a. Semigroup a => a -> a -> a
<>
  forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
pkg) forall a. Semigroup a => a -> a -> a
<>
  (if BuildOpts -> Bool
boptsTests BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest (forall k a. Map k a -> [k]
M.keys (Package -> Map Text TestSuiteInterface
packageTests Package
pkg)) else []) forall a. Semigroup a => a -> a -> a
<>
  (if BuildOpts -> Bool
boptsBenchmarks BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageBenchmarks Package
pkg)) else [])
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = forall a. Set a
S.empty

checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [GhciPkgInfo]
pkgs forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ do
    -- Cabal flag issues could arise only when there are at least 2 packages

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StyleDoc]
cabalFlagIssues) forall a b. (a -> b) -> a -> b
$ do
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn 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."
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine [StyleDoc]
cabalFlagIssues)
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        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."
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    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" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
 where
  cabalFlagIssues :: [StyleDoc]
cabalFlagIssues = 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" 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 (forall a. Eq a => a -> a -> Bool
== String
flag) in
    [ [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
msgs forall a. [a] -> [a] -> [a]
++ ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x | 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 forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [a]
ys 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:" ]
    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
         (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
haveIt :: [StyleDoc])
    forall a. Semigroup a => a -> a -> a
<> [ String -> StyleDoc
flow String
"But not for:" ]
    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
         (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack 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 = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
xs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
ys)
   where
    ([((PackageName, NamedComponent), [String])]
xs, [((PackageName, NamedComponent), [String])]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((PackageName, NamedComponent), [String])]
compsWithOpts
  compsWithOpts :: [((PackageName, NamedComponent), [String])]
compsWithOpts = forall a b. (a -> b) -> [a] -> [b]
map (\((PackageName, NamedComponent)
k, BuildInfoOpts
bio) ->
    ((PackageName, NamedComponent)
k, BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio 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 =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"Multiple files use the same module name:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (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)
      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 =
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(ModuleName
_, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) -> forall k a. Map k a -> Int
M.size Map (Path Abs File) (Set (PackageName, NamedComponent))
mp forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
    forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
    [ModuleMap] -> ModuleMap
unionModuleMaps (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 (forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn)
         , String -> StyleDoc
flow String
"found at the following paths"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (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
      [ forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
      , StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$
          [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
nonLocalTargets) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ String -> StyleDoc
flow String
"Some targets"
      , StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Good forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString 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."
      ]
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) forall a b. (a -> b) -> a -> b
$ do
      SMWanted
smWanted <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> SMWanted
bcSMWanted
      Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote 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 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$
                   Utf8Builder
"You are using snapshot: " forall a. Semigroup a => a -> a -> a
<>
                   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
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml 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
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml 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 =
    forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
    (\Map PackageName (Path Abs File, Target)
mp -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map PackageName (Path Abs File, Target)
mp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PackageName, (Path Abs File, Target))]
targets)) forall a b. (a -> b) -> a -> b
$
    forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
    forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [PackageName]
getDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
targets)
              (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Maybe a
Just) [(PackageName, (Path Abs File, Target))]
targets))
  where
    getDeps :: PackageName -> [PackageName]
    getDeps :: PackageName -> [PackageName]
getDeps PackageName
name =
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap of
            Just LocalPackage
lp -> 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
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go PackageName
name = do
        Map PackageName (Maybe (Path Abs File, Target))
cache <- forall s (m :: * -> *). MonadState s m => m s
get
        case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Maybe (Path Abs File, Target))
cache, 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
_) -> 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 -> 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 = forall k a. Map k a -> [k]
M.keys (Package -> Map PackageName DepValue
packageDeps (LocalPackage -> Package
lpPackage LocalPackage
lp))
                Bool
shouldLoad <- forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go [PackageName]
deps
                if Bool
shouldLoad
                    then do
                        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name (forall a. a -> Maybe a
Just (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp, Set NamedComponent -> Target
TargetComps (forall a. a -> Set a
S.singleton NamedComponent
CLib))))
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    else do
                        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name forall a. Maybe a
Nothing)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            (Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> 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 = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith 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 (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 -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
p (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 =
  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 forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> do
    (ByteString
out, ByteString
_err) <- forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack
      forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
TL.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')
      forall a b. (a -> b) -> a -> b
$ [Text] -> Text
TL.concat
      forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1
      forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines
      forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
lenientDecode ByteString
out