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

-- | 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 qualified Data.List as L
import           Data.List.Extra ( (!?) )
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import           Path ((</>), parent, parseRelFile )
import           Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
import           Path.IO
                   ( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir )
import           RIO.NonEmpty ( nonEmpty )
import           RIO.Process ( exec, 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, cmdModule
                   , scriptToLazyByteString
                   )
import           Stack.Package
                   ( buildableExes, buildableForeignLibs, getPackageOpts
                   , hasBuildableMainLibrary, listOfPackageDeps
                   , packageFromPackageDescription, readDotBuildinfo
                   , resolvePackageDescription, topSortPackageComponent
                   )
import           Stack.PackageFile ( getPackageFile )
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 ( BuildOpts (..) )
import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) )
import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) )
import           Stack.Types.BuildOptsCLI
                   ( ApplyCLIFlag, BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.CompCollection ( getBuildableListText )
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.Installed ( InstallMap, InstalledMap )
import           Stack.Types.NamedComponent
                   ( NamedComponent (..), isCLib, isCSubLib, renderComponentTo
                   , renderPkgComponent
                   )
import           Stack.Types.Package
                   ( BuildInfoOpts (..), LocalPackage (..), Package (..)
                   , PackageConfig (..), dotCabalCFilePath, dotCabalGetPath
                   , dotCabalMainPath
                   )
import           Stack.Types.PackageFile ( PackageComponentFile (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner, Runner )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), GlobalPackage
                   , PackageType (..), ProjectPackage (..), SMActual (..)
                   , SMTargets (..), SMWanted (..), SourceMap (..), Target (..)
                   )
import           System.IO ( putStrLn )
import           System.Permissions ( setScriptPerms )

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

-- "Stack.Ghci" module.

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

instance Exception GhciException where
  displayException :: GhciException -> String
displayException (InvalidPackageOption String
name) =
    String
"Error: [S-6716]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Failed to parse '--package' option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  displayException GhciException
LoadingDuplicateModules = [String] -> String
unlines
    [ String
"Error: [S-9632]"
    , String
"Not attempting to start ghci due to these duplicate modules."
    , String
"Use '--no-load' to try to start it anyway, without loading any \
      \modules (but these are still likely to cause errors)."
    ]
  displayException (MissingFileTarget String
name) =
    String
"Error: [S-3600]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot find file target " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
  displayException GhciException
Can'tSpecifyFilesAndTargets =
    String
"Error: [S-9906]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and package targets."
  displayException GhciException
Can'tSpecifyFilesAndMainIs =
    String
"Error: [S-5188]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and '--main-is' \
       \flag."

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

-- "Stack.Ghci" module.

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

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

instance Exception GhciPrettyException

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

-- @stack repl@ commands.

data GhciOpts = GhciOpts
  { GhciOpts -> [Text]
targets            :: ![Text]
  , GhciOpts -> [String]
args               :: ![String]
  , GhciOpts -> [String]
ghcOptions         :: ![String]
  , GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
flags              :: !(Map ApplyCLIFlag (Map FlagName Bool))
  , GhciOpts -> Maybe String
ghcCommand         :: !(Maybe FilePath)
  , GhciOpts -> Bool
noLoadModules      :: !Bool
  , GhciOpts -> [String]
additionalPackages :: ![String]
  , GhciOpts -> Maybe Text
mainIs             :: !(Maybe Text)
  , GhciOpts -> Bool
loadLocalDeps      :: !Bool
  , GhciOpts -> Bool
skipIntermediate   :: !Bool
  , GhciOpts -> Maybe Bool
hidePackages       :: !(Maybe Bool)
  , GhciOpts -> Bool
noBuild            :: !Bool
  , GhciOpts -> Bool
onlyMain           :: !Bool
  }
  deriving Int -> GhciOpts -> ShowS
[GhciOpts] -> ShowS
GhciOpts -> String
(Int -> GhciOpts -> ShowS)
-> (GhciOpts -> String) -> ([GhciOpts] -> ShowS) -> Show GhciOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciOpts -> ShowS
showsPrec :: Int -> GhciOpts -> ShowS
$cshow :: GhciOpts -> String
show :: GhciOpts -> String
$cshowList :: [GhciOpts] -> ShowS
showList :: [GhciOpts] -> ShowS
Show

-- | Type representing information required to load a package or its components.

--

-- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order

-- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786

data GhciPkgInfo = GhciPkgInfo
  { GhciPkgInfo -> PackageName
name :: !PackageName
  , GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
opts :: ![(NamedComponent, BuildInfoOpts)]
  , GhciPkgInfo -> Path Abs Dir
dir :: !(Path Abs Dir)
  , GhciPkgInfo -> ModuleMap
modules :: !ModuleMap
  , GhciPkgInfo -> [Path Abs File]
cFiles :: ![Path Abs File] -- ^ C files.

  , GhciPkgInfo -> Map NamedComponent [Path Abs File]
mainIs :: !(Map NamedComponent [Path Abs File])
  , GhciPkgInfo -> Maybe [Path Abs File]
targetFiles :: !(Maybe [Path Abs File])
  , GhciPkgInfo -> Package
package :: !Package
  }
  deriving Int -> GhciPkgInfo -> ShowS
[GhciPkgInfo] -> ShowS
GhciPkgInfo -> String
(Int -> GhciPkgInfo -> ShowS)
-> (GhciPkgInfo -> String)
-> ([GhciPkgInfo] -> ShowS)
-> Show GhciPkgInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshow :: GhciPkgInfo -> String
show :: GhciPkgInfo -> String
$cshowList :: [GhciPkgInfo] -> ShowS
showList :: [GhciPkgInfo] -> ShowS
Show

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

data GhciPkgDesc = GhciPkgDesc
  { GhciPkgDesc -> Package
package :: !Package
  , GhciPkgDesc -> Path Abs File
cabalFP :: !(Path Abs File)
  , GhciPkgDesc -> Target
target :: !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.

-- The purpose of this complex structure is for use in

-- 'checkForDuplicateModules'.

type ModuleMap =
  Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent)))

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

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

-- the context of a project.

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

        { targetsCLI = map T.pack ghciOpts.additionalPackages
        , initialBuildSteps = True
        , flags = ghciOpts.flags
        , ghcOptions = map T.pack ghciOpts.ghcOptions
        }
  in  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
        BuildOpts
bopts <- Getting BuildOpts EnvConfig BuildOpts -> RIO EnvConfig BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts EnvConfig BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL
        -- override env so running of tests and benchmarks is disabled

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

-- | Launch a GHCi session for the given local package targets with the

-- given options and configure it with the load paths and extensions

-- of those targets.

ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci :: forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
opts = do
  let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        { targetsCLI = []
        , flags = opts.flags
        }
  SourceMap
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const SourceMap EnvConfig)
 -> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
    -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap)
  InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  [LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
  [LocalPackage]
depLocals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
  let localMap :: Map PackageName LocalPackage
localMap =
        [(PackageName, LocalPackage)] -> Map PackageName LocalPackage
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(LocalPackage
lp.package.name, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals [LocalPackage] -> [LocalPackage] -> [LocalPackage]
forall a. [a] -> [a] -> [a]
++ [LocalPackage]
depLocals]
      -- FIXME:qrilka this looks wrong to go back to SMActual

      sma :: SMActual GlobalPackage
sma = SMActual
        { $sel:compiler:SMActual :: ActualCompiler
compiler = SourceMap
sourceMap.compiler
        , $sel:project:SMActual :: Map PackageName ProjectPackage
project = SourceMap
sourceMap.project
        , $sel:deps:SMActual :: Map PackageName DepPackage
deps = SourceMap
sourceMap.deps
        , $sel:globals:SMActual :: Map PackageName GlobalPackage
globals = SourceMap
sourceMap.globalPkgs
        }
  -- Parse --main-is argument.

  Maybe (Map PackageName Target)
mainIsTargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma GhciOpts
opts.mainIs
  -- Parse to either file targets or build targets

  Either [Path Abs File] (Map PackageName Target)
etargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma GhciOpts
opts.targets
  (Map PackageName Target
inputTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) <- case Either [Path Abs File] (Map PackageName Target)
etargets of
    Right Map PackageName Target
packageTargets -> (Map PackageName Target,
 Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
     env
     (Map PackageName Target,
      Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
packageTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. Maybe a
Nothing)
    Left [Path Abs File]
rawFileTargets -> do
      case Maybe (Map PackageName Target)
mainIsTargets of
        Maybe (Map PackageName Target)
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Map PackageName Target
_ -> GhciException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM GhciException
Can'tSpecifyFilesAndMainIs
      -- Figure out targets based on filepath targets

      (Map PackageName Target
targetMap, Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles) <- [LocalPackage]
-> [Path Abs File]
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
     env
     (Map PackageName Target, Map PackageName [Path Abs File],
      [Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
rawFileTargets
      (Map PackageName Target,
 Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
     env
     (Map PackageName Target,
      Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. a -> Maybe a
Just (Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles))
  -- Get a list of all the local target packages.

  [(PackageName, (Path Abs File, Target))]
localTargets <- GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
opts Map PackageName Target
inputTargets Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap
  -- Get a list of all the non-local target packages.

  [PackageName]
nonLocalTargets <- Map PackageName Target -> RIO env [PackageName]
forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
  let getInternalDependencies :: Target -> r -> Seq NamedComponent
getInternalDependencies Target
target r
localPackage =
        Package -> Target -> Bool -> Seq NamedComponent
topSortPackageComponent r
localPackage.package Target
target Bool
False
      internalDependencies :: Map PackageName (Seq NamedComponent)
internalDependencies =
        (Target -> LocalPackage -> Seq NamedComponent)
-> Map PackageName Target
-> Map PackageName LocalPackage
-> Map PackageName (Seq NamedComponent)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Target -> LocalPackage -> Seq NamedComponent
forall {r}.
HasField "package" r Package =>
Target -> r -> Seq NamedComponent
getInternalDependencies Map PackageName Target
inputTargets Map PackageName LocalPackage
localMap
      relevantDependencies :: Map PackageName (Seq NamedComponent)
relevantDependencies = (Seq NamedComponent -> Bool)
-> Map PackageName (Seq NamedComponent)
-> Map PackageName (Seq NamedComponent)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((NamedComponent -> Bool) -> Seq NamedComponent -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCSubLib) Map PackageName (Seq NamedComponent)
internalDependencies
  -- Check if additional package arguments are sensible.

  [PackageName]
addPkgs <- [String] -> RIO env [PackageName]
forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages GhciOpts
opts.additionalPackages
  -- Load package descriptions.

  [GhciPkgDesc]
pkgDescs <- BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets
  -- If necessary, ask user about which main module to load.

  BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
  Maybe (Path Abs File)
mainFile <- if GhciOpts
opts.noLoadModules
    then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
    else do
      -- Figure out package files, in order to ask the user about which main

      -- module to load. See the note below for why this is done again after the

      -- build. This could potentially be done more efficiently, because all we

      -- need is the location of main modules, not the rest.

      [GhciPkgInfo]
pkgs0 <- InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (((Map PackageName [Path Abs File], [Path Abs File])
 -> Map PackageName [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File]
forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
      BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
localTargets [GhciPkgInfo]
pkgs0
  let pkgTargets :: PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
targets =
        case Target
targets of
          TargetAll PackageType
_  -> [String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pn)]
          TargetComps Set NamedComponent
comps -> [(PackageName, NamedComponent) -> Text
renderPkgComponent (PackageName
pn, NamedComponent
c) | NamedComponent
c <- Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps]
  -- Build required dependencies and setup local packages.

  GhciOpts -> [Text] -> RIO env ()
forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
opts ([Text] -> RIO env ()) -> [Text] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    ((PackageName, (Path Abs File, Target)) -> [Text])
-> [(PackageName, (Path Abs File, Target))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
pn, (Path Abs File
_, Target
t)) -> PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
t) [(PackageName, (Path Abs File, Target))]
localTargets
  [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets
  -- Load the list of modules _after_ building, to catch changes in

  -- unlisted dependencies (#1180)

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

  GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci
    GhciOpts
opts
    [(PackageName, (Path Abs File, Target))]
localTargets
    Maybe (Path Abs File)
mainFile
    [GhciPkgInfo]
pkgs
    ([Path Abs File]
-> ((Map PackageName [Path Abs File], [Path Abs File])
    -> [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall a b. (a, b) -> b
snd Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets)
    ([PackageName]
nonLocalTargets [PackageName] -> [PackageName] -> [PackageName]
forall a. [a] -> [a] -> [a]
++ [PackageName]
addPkgs)
    Map PackageName (Seq NamedComponent)
relevantDependencies

preprocessTargets ::
     HasEnvConfig env
  => BuildOptsCLI
  -> SMActual GlobalPackage
  -> [Text]
  -> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
rawTargets = do
  let ([Text]
fileTargetsRaw, [Text]
normalTargetsRaw) =
        (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition
          (\Text
t -> Text
".hs" Text -> Text -> Bool
`T.isSuffixOf` Text
t Bool -> Bool -> Bool
|| Text
".lhs" Text -> Text -> Bool
`T.isSuffixOf` Text
t)
          [Text]
rawTargets
  -- Only use file targets if we have no normal targets.

  if Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
normalTargetsRaw
    then do
      [Path Abs File]
fileTargets <- [Text]
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fileTargetsRaw ((Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File])
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ \Text
fp0 -> do
        let fp :: String
fp = Text -> String
T.unpack Text
fp0
        Maybe (Path Abs File)
mpath <- String -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
String -> m (Maybe (Path Abs File))
forgivingResolveFile' String
fp
        case Maybe (Path Abs File)
mpath of
          Maybe (Path Abs File)
Nothing -> GhciException -> RIO env (Path Abs File)
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (String -> GhciException
MissingFileTarget String
fp)
          Just Path Abs File
path -> Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
      Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path Abs File] -> Either [Path Abs File] (Map PackageName Target)
forall a b. a -> Either a b
Left [Path Abs File]
fileTargets)
    else do
      -- Try parsing targets before checking if both file and

      -- module targets are specified (see issue#3342).

      let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { targetsCLI = normalTargetsRaw }
      SMTargets
normalTargets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
        RIO env SMTargets
-> (PrettyException -> RIO env SMTargets) -> RIO env SMTargets
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
          case SomeException -> Maybe BuildPrettyException
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe BuildPrettyException)
-> SomeException -> Maybe BuildPrettyException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex of
            Just (TargetParseException [StyleDoc]
xs) ->
              GhciPrettyException -> RIO env SMTargets
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (GhciPrettyException -> RIO env SMTargets)
-> GhciPrettyException -> RIO env SMTargets
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
            Maybe BuildPrettyException
_ -> PrettyException -> RIO env SMTargets
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PrettyException
pex
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ GhciException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
      Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
-> Either [Path Abs File] (Map PackageName Target)
forall a b. b -> Either a b
Right SMTargets
normalTargets.targets)

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

-- | Display PackageName + NamedComponent

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

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

getAllLocalTargets ::
     HasEnvConfig env
  => GhciOpts
  -> Map PackageName Target
  -> Maybe (Map PackageName Target)
  -> Map PackageName LocalPackage
  -> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets :: forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
ghciOpts Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
  -- Use the 'mainIsTargets' as normal targets, for CLI concision. See

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

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

  -- specified.

  let targets :: Map PackageName Target
targets = Map PackageName Target
-> (Map PackageName Target -> Map PackageName Target)
-> Maybe (Map PackageName Target)
-> Map PackageName Target
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PackageName Target
targets0 (Map PackageName Target
-> Map PackageName Target -> Map PackageName Target
forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
targets0) Maybe (Map PackageName Target)
mainIsTargets
  Map PackageName ProjectPackage
packages <- Getting
  (Map PackageName ProjectPackage)
  env
  (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   env
   (Map PackageName ProjectPackage)
 -> RIO env (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
 -> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> Map PackageName ProjectPackage)
-> SimpleGetter EnvConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap.project)
  -- Find all of the packages that are directly demanded by the

  -- targets.

  let directlyWanted :: [(PackageName, (Path Abs File, Target))]
directlyWanted = (((PackageName, ProjectPackage)
  -> Maybe (PackageName, (Path Abs File, Target)))
 -> [(PackageName, ProjectPackage)]
 -> [(PackageName, (Path Abs File, Target))])
-> [(PackageName, ProjectPackage)]
-> ((PackageName, ProjectPackage)
    -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PackageName, ProjectPackage)
 -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName ProjectPackage
packages) (((PackageName, ProjectPackage)
  -> Maybe (PackageName, (Path Abs File, Target)))
 -> [(PackageName, (Path Abs File, Target))])
-> ((PackageName, ProjectPackage)
    -> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
        \(PackageName
name, ProjectPackage
pp) ->
              case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName Target
targets of
                Just Target
simpleTargets -> (PackageName, (Path Abs File, Target))
-> Maybe (PackageName, (Path Abs File, Target))
forall a. a -> Maybe a
Just (PackageName
name, (ProjectPackage
pp.cabalFP, Target
simpleTargets))
                Maybe Target
Nothing -> Maybe (PackageName, (Path Abs File, Target))
forall a. Maybe a
Nothing
  -- Figure out

  let extraLoadDeps :: [(PackageName, (Path Abs File, Target))]
extraLoadDeps =
        Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps GhciOpts
ghciOpts.loadLocalDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
directlyWanted
  if    (GhciOpts
ghciOpts.skipIntermediate Bool -> Bool -> Bool
&& Bool -> Bool
not GhciOpts
ghciOpts.loadLocalDeps)
     Bool -> Bool -> Bool
|| [(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
    then [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
    else do
      let extraList' :: [StyleDoc]
extraList' =
            ((PackageName, (Path Abs File, Target)) -> StyleDoc)
-> [(PackageName, (Path Abs File, Target))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc)
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps :: [StyleDoc]
          extraList :: [StyleDoc]
extraList = Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
      if GhciOpts
ghciOpts.loadLocalDeps
        then StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                [ String -> StyleDoc
flow String
"The following libraries will also be loaded into \
                       \GHCi because they are local dependencies of your \
                       \targets, and you specified"
                , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--load-local-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                ]
            [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
        else StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               ( String -> StyleDoc
flow String
"The following libraries will also be loaded into \
                      \GHCi because they are intermediate dependencies of \
                      \your targets:"
               StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
               )
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"(Use"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--skip-intermediate-deps"
               , String -> StyleDoc
flow String
"to omit these.)"
               ]
      [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)

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

buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
ghciOpts [Text]
localTargets = do
  let targets :: [Text]
targets = [Text]
localTargets [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack GhciOpts
ghciOpts.additionalPackages
  -- If necessary, do the build, for local packagee targets, only do

  -- 'initialBuildSteps'.

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

    Just NonEmpty Text
nonEmptyTargets | Bool -> Bool
not GhciOpts
ghciOpts.noBuild -> do
      Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
      case Either SomeException ()
eres of
        Right () -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left SomeException
err -> do
          case SomeException -> Maybe PrettyException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
            Just (PrettyException e
prettyErr) -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
            Maybe PrettyException
Nothing -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
forall a. IsString a => String -> a
fromString (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
          StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
"Build failed, but trying to launch GHCi anyway"
    Maybe (NonEmpty Text)
_ ->
      () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

runGhci ::
     HasEnvConfig env
  => GhciOpts
  -> [(PackageName, (Path Abs File, Target))]
  -> Maybe (Path Abs File)
  -> [GhciPkgInfo]
  -> [Path Abs File]
  -> [PackageName]
  -> Map PackageName (Seq NamedComponent)
  -> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci
    GhciOpts
ghciOpts
    [(PackageName, (Path Abs File, Target))]
targets
    Maybe (Path Abs File)
mainFile
    [GhciPkgInfo]
pkgs
    [Path Abs File]
extraFiles
    [PackageName]
exposePackages
    Map PackageName (Seq NamedComponent)
exposeInternalDep
  = do
      Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
      let subDepsPackageUnhide :: PackageName -> t a -> [a]
subDepsPackageUnhide PackageName
pName t a
deps =
            if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
deps then [] else [a
"-package", PackageName -> a
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pName]
          pkgopts :: [String]
pkgopts = [String]
hidePkgOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
genOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
          shouldHidePackages :: Bool
shouldHidePackages = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe
            (Bool -> Bool
not ([GhciPkgInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages))
            GhciOpts
ghciOpts.hidePackages
          hidePkgOpts :: [String]
hidePkgOpts =
            if Bool
shouldHidePackages
              then
                   [String
"-hide-all-packages"]
                -- 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.

                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if [(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else [])
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PackageName -> [String]) -> [PackageName] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                     (\PackageName
n -> [String
"-package", PackageName -> String
packageNameString PackageName
n])
                     [PackageName]
exposePackages
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PackageName -> Seq NamedComponent -> [String])
-> Map PackageName (Seq NamedComponent) -> [String]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey PackageName -> Seq NamedComponent -> [String]
forall {t :: * -> *} {a} {a}.
(Foldable t, IsString a) =>
PackageName -> t a -> [a]
subDepsPackageUnhide Map PackageName (Seq NamedComponent)
exposeInternalDep
              else []
          oneWordOpts :: r -> [a]
oneWordOpts r
bio
            | Bool
shouldHidePackages = r
bio.oneWordOpts [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ r
bio.packageFlags
            | Bool
otherwise = r
bio.oneWordOpts
          genOpts :: [String]
genOpts = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd
            ((GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
forall {r} {a}.
(HasField "packageFlags" r [a], HasField "oneWordOpts" r [a]) =>
r -> [a]
oneWordOpts (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.opts)) [GhciPkgInfo]
pkgs)
          ([String]
omittedOpts, [String]
ghcOpts) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition String -> Bool
badForGhci ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$
               (GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((.opts) (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.opts)) [GhciPkgInfo]
pkgs
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
                 Text -> String
T.unpack
                 (  Map ApplyGhcOptions [Text] -> [Text]
forall m. Monoid m => Map ApplyGhcOptions m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Config
config.ghcOptionsByCat
                    -- ^ include everything, locals, and targets

                 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (GhciPkgInfo -> [Text]) -> [GhciPkgInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions (PackageName -> [Text])
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name)) [GhciPkgInfo]
pkgs
                 )
          getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg =
            [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PackageName
pkg Config
config.ghcOptionsByName
          badForGhci :: String -> Bool
badForGhci String
x =
               String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"-O" String
x
            Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               ( String -> StyleDoc
flow String
"The following GHC options are incompatible with GHCi \
                      \and have not been passed to it:"
               StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
                   ((String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
forall a. IsString a => String -> a
fromString ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts) :: [StyleDoc])
               )
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      Path Abs Dir
oiDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
      let odir :: [String]
odir =
            [ String
"-odir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
            , String
"-hidir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
            ]
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        ( String -> StyleDoc
flow String
"Configuring GHCi with the following packages:"
        StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
            ((GhciPkgInfo -> StyleDoc) -> [GhciPkgInfo] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc)
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name)) [GhciPkgInfo]
pkgs :: [StyleDoc])
        )
      String
compilerExeName <-
        Getting String env String -> RIO env String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting String env String -> RIO env String)
-> Getting String env String -> RIO env String
forall a b. (a -> b) -> a -> b
$ Getting String env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL Getting String env CompilerPaths
-> ((String -> Const String String)
    -> CompilerPaths -> Const String CompilerPaths)
-> Getting String env String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.compiler) Getting String CompilerPaths (Path Abs File)
-> ((String -> Const String String)
    -> Path Abs File -> Const String (Path Abs File))
-> (String -> Const String String)
-> CompilerPaths
-> Const String CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> String) -> SimpleGetter (Path Abs File) String
forall s a. (s -> a) -> SimpleGetter s a
to Path Abs File -> String
forall b t. Path b t -> String
toFilePath
      let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
            ProcessContext
menv <-
              IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config
config.processContextSettings EnvSettings
defaultEnvSettings
            RIO env b -> RIO env b
forall {a}. RIO env a -> RIO env a
withPackageWorkingDir (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ ProcessContext -> RIO env b -> RIO env b
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO env b
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
              (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName GhciOpts
ghciOpts.ghcCommand)
              ( (String
"--interactive" : ) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                -- This initial "-i" resets the include directories to not

                -- include CWD. If there aren't any packages, CWD is included.

                (if [GhciPkgInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then [String] -> [String]
forall a. a -> a
id else (String
"-i" : )) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                     [String]
odir
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
extras
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> GhciOpts
ghciOpts.ghcOptions
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> GhciOpts
ghciOpts.args
              )
          withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
            case [GhciPkgInfo]
pkgs of
              [GhciPkgInfo
pkg] -> String -> RIO env a -> RIO env a
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath GhciPkgInfo
pkg.dir)
              [GhciPkgInfo]
_ -> RIO env a -> RIO env a
forall a. a -> a
id
      -- Since usage of 'exec' does not pure, we cannot do any cleanup on ghci

      -- exit. So, instead leave the generated files. To make this more

      -- efficient and avoid gratuitous generation of garbage, the file names

      -- are determined by hashing. This also has the nice side effect of making

      -- it possible to copy the ghci invocation out of the log and have it

      -- still work.

      Path Abs Dir
tmpDirectory <- XdgDirectory -> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgCache (Maybe (Path Rel Dir) -> RIO env (Path Abs Dir))
-> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
        Path Rel Dir -> Maybe (Path Rel Dir)
forall a. a -> Maybe a
Just (Path Rel Dir
relDirStackProgName Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGhciScript)
      Path Abs Dir
ghciDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
      Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
      Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
      [String]
macrosOptions <- Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
      if GhciOpts
ghciOpts.noLoadModules
        then [String] -> RIO env ()
forall {b}. [String] -> RIO env b
execGhci [String]
macrosOptions
        else do
          [GhciPkgInfo] -> RIO env ()
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
          [String]
scriptOptions <-
            Path Abs Dir -> GhciScript -> RIO env [String]
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript
              Path Abs Dir
tmpDirectory
              ([GhciPkgInfo]
-> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile GhciOpts
ghciOpts.onlyMain [Path Abs File]
extraFiles)
          [String] -> RIO env ()
forall {b}. [String] -> RIO env b
execGhci ([String]
macrosOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
scriptOptions)

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

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

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

renderScript ::
     [GhciPkgInfo]
  -> Maybe (Path Abs File)
  -> Bool
  -> [Path Abs File]
  -> GhciScript
renderScript :: [GhciPkgInfo]
-> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
  let addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (Set (Either ModuleName (Path Abs File)) -> GhciScript)
-> Set (Either ModuleName (Path Abs File)) -> GhciScript
forall a b. (a -> b) -> a -> b
$ [Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((ModuleName -> Either ModuleName (Path Abs File))
-> [ModuleName] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either ModuleName (Path Abs File)
forall a b. a -> Either a b
Left [ModuleName]
allModules [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
forall a. [a] -> [a] -> [a]
++ [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
      addMain :: [Either a (Path Abs File)]
addMain = [Either a (Path Abs File)]
-> (Path Abs File -> [Either a (Path Abs File)])
-> Maybe (Path Abs File)
-> [Either a (Path Abs File)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Either a (Path Abs File) -> [Either a (Path Abs File)]
forall a. a -> [a]
L.singleton (Either a (Path Abs File) -> [Either a (Path Abs File)])
-> (Path Abs File -> Either a (Path Abs File))
-> Path Abs File
-> [Either a (Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Either a (Path Abs File)
forall a b. b -> Either a b
Right) Maybe (Path Abs File)
mainFile
      modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule (Set ModuleName -> GhciScript) -> Set ModuleName -> GhciScript
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
      allModules :: [ModuleName]
allModules = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
nubOrd ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (GhciPkgInfo -> [ModuleName]) -> [GhciPkgInfo] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleMap -> [ModuleName]
forall k a. Map k a -> [k]
M.keys (ModuleMap -> [ModuleName])
-> (GhciPkgInfo -> ModuleMap) -> GhciPkgInfo -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.modules)) [GhciPkgInfo]
pkgs
  case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
    [] ->
      if Bool
onlyMain
        then
          if Maybe (Path Abs File) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile
            then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
            else GhciScript
forall a. Monoid a => a
mempty
        else GhciScript
addPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
    [Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((Path Abs File -> Either ModuleName (Path Abs File))
-> [Path Abs File] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> Either ModuleName (Path Abs File)
forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))

-- Hacky check if module / main phase should be omitted. This should be

-- improved if / when we have a better per-component load.

getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets = (GhciPkgInfo -> [Path Abs File])
-> [GhciPkgInfo] -> [Path Abs File]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Path Abs File]] -> [Path Abs File])
-> (GhciPkgInfo -> [[Path Abs File]])
-> GhciPkgInfo
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Path Abs File] -> [[Path Abs File]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Path Abs File] -> [[Path Abs File]])
-> (GhciPkgInfo -> Maybe [Path Abs File])
-> GhciPkgInfo
-> [[Path Abs File]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.targetFiles))

-- | Figure out the main-is file to load based on the targets. Asks the user for

-- input if there is more than one candidate main-is file.

figureOutMainFile ::
     (HasRunner env, HasTerm env)
  => BuildOpts
  -> Maybe (Map PackageName Target)
  -> [(PackageName, (Path Abs File, Target))]
  -> [GhciPkgInfo]
  -> RIO env (Maybe (Path Abs File))
figureOutMainFile :: forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
targets0 [GhciPkgInfo]
packages =
  case [(PackageName, NamedComponent, Path Abs File)]
candidates of
    [] -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
    [c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ StyleDoc
"Using"
             , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
             , StyleDoc
"module:"
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate (PackageName, NamedComponent, Path Abs File)
c
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp)
    (PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ StyleDoc
"The"
             , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
             , String -> StyleDoc
flow String
"module to load is ambiguous. Candidates are:"
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line (((PackageName, NamedComponent, Path Abs File) -> StyleDoc)
-> [(PackageName, NamedComponent, Path Abs File)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates))
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You can specify which one to pick by:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
             [ [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"Specifying targets to"
                 , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack ghci")
                 , StyleDoc
"e.g."
                 , Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
                                   [ String -> StyleDoc
flow String
"stack ghci"
                                   , (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {a} {c}.
(Semigroup a, IsString a) =>
(PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate
                                   ]
                               ) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                 ]
             , [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"Specifying what the"
                 , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
                 , String -> StyleDoc
flow String
"is e.g."
                 , Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
                                   [ String -> StyleDoc
flow String
"stack ghci"
                                   , (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {c}. (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate
                                   ]
                               ) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                 ]
              , String -> StyleDoc
flow
                  (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$  String
"Choosing from the candidate above [1.."
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates)
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]."
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
 where
  targets :: Map PackageName Target
targets = Map PackageName Target
-> Maybe (Map PackageName Target) -> Map PackageName Target
forall a. a -> Maybe a -> a
fromMaybe
    ([(PackageName, Target)] -> Map PackageName Target
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, Target)] -> Map PackageName Target)
-> [(PackageName, Target)] -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ ((PackageName, (Path Abs File, Target)) -> (PackageName, Target))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Target)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
k, (Path Abs File
_, Target
x)) -> (PackageName
k, Target
x)) [(PackageName, (Path Abs File, Target))]
targets0)
    Maybe (Map PackageName Target)
mainIsTargets
  candidates :: [(PackageName, NamedComponent, Path Abs File)]
candidates = do
    GhciPkgInfo
pkg <- [GhciPkgInfo]
packages
    case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GhciPkgInfo
pkg.name Map PackageName Target
targets of
      Maybe Target
Nothing -> []
      Just Target
target -> do
        (NamedComponent
component,[Path Abs File]
mains) <-
          Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent [Path Abs File]
 -> [(NamedComponent, [Path Abs File])])
-> Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall a b. (a -> b) -> a -> b
$
          (NamedComponent -> [Path Abs File] -> Bool)
-> Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
wantedComponents)
                          GhciPkgInfo
pkg.mainIs
        Path Abs File
main <- [Path Abs File]
mains
        (PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GhciPkgInfo
pkg.name, NamedComponent
component, Path Abs File
main)
       where
        wantedComponents :: Set NamedComponent
wantedComponents =
          BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target GhciPkgInfo
pkg.package
  renderCandidate :: (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName, NamedComponent
namedComponent, Path Abs File
mainIs) =
    let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex =
          String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ([(PackageName, NamedComponent, Path Abs File)] -> String)
-> [(PackageName, NamedComponent, Path Abs File)]
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Maybe Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
        pkgNameText :: StyleDoc
pkgNameText = PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkgName
    in  Int -> StyleDoc -> StyleDoc
hang Int
4
          (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$  Int -> StyleDoc -> StyleDoc
fill Int
4 ( [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
".")
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ StyleDoc
"Package"
               , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgNameText StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
               , StyleDoc
"component"
                 -- This is the format that can be directly copy-pasted as an

                 -- argument to `stack ghci`.

               , Style -> StyleDoc -> StyleDoc
style
                   Style
PkgComponent
                   (  StyleDoc
pkgNameText
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
namedComponent
                   )
                 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
               , StyleDoc
"with"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"main-is"
               , StyleDoc
"file:"
               , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
mainIs StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
  candidateIndices :: [Int]
candidateIndices = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) [Int
1 :: Int ..]
  userOption :: IO (Maybe (Path Abs File))
userOption = do
    Text
option <- Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
    let selected :: Int
selected = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
          ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
          (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
    case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
selected [Int]
candidateIndices of
      Maybe Int
Nothing -> do
        String -> IO ()
putStrLn
          String
"Not loading any main modules, as no valid module selected"
        String -> IO ()
putStrLn String
""
        Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
      Just Int
op -> do
        (PackageName
_, NamedComponent
_, Path Abs File
fp) <- IO (PackageName, NamedComponent, Path Abs File)
-> ((PackageName, NamedComponent, Path Abs File)
    -> IO (PackageName, NamedComponent, Path Abs File))
-> Maybe (PackageName, NamedComponent, Path Abs File)
-> IO (PackageName, NamedComponent, Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (GhciPrettyException
-> IO (PackageName, NamedComponent, Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO GhciPrettyException
CandidatesIndexOutOfRangeBug)
          (PackageName, NamedComponent, Path Abs File)
-> IO (PackageName, NamedComponent, Path Abs File)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ([(PackageName, NamedComponent, Path Abs File)]
candidates [(PackageName, NamedComponent, Path Abs File)]
-> Int -> Maybe (PackageName, NamedComponent, Path Abs File)
forall a. [a] -> Int -> Maybe a
!? Int
op)
        String -> IO ()
putStrLn
          (String
"Loading main module from candidate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Int -> String
forall a. Show a => a -> String
show (Int
op Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", --main-is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp)
        String -> IO ()
putStrLn String
""
        Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File) -> IO (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp
  sampleTargetArg :: (PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName
pkg, NamedComponent
comp, c
_) =
       PackageName -> a
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkg
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
":"
    a -> a -> a
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> a
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
comp
  sampleMainIsArg :: (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName
pkg, NamedComponent
comp, c
_) =
    [StyleDoc] -> StyleDoc
fillSep
      [ StyleDoc
"--main-is"
      , PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkg StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
comp
      ]

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

-- | Load package description information for a ghci target.

loadGhciPkgDesc ::
     HasEnvConfig env
  => BuildOptsCLI
  -> PackageName
  -> Path Abs File
  -> Target
  -> RIO env GhciPkgDesc
loadGhciPkgDesc :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalFP Target
target = do
  EnvConfig
econfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
  ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  let sm :: SourceMap
sm = EnvConfig
econfig.sourceMap
      -- Currently this source map is being build with

      -- the default targets

      sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        ((.projectCommon.ghcOptions) (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project)
        Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        ((.depCommon.ghcOptions) (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.deps)
      sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        ( (.projectCommon.cabalConfigOpts) (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project)
        Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        ((.depCommon.cabalConfigOpts) (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.deps)
      sourceMapFlags :: Map FlagName Bool
sourceMapFlags =
        Map FlagName Bool
-> (ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage
-> Map FlagName Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map FlagName Bool
forall a. Monoid a => a
mempty (.projectCommon.flags) (Maybe ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage -> Map FlagName Bool
forall a b. (a -> b) -> a -> b
$ PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project
      config :: PackageConfig
config = PackageConfig
        { $sel:enableTests:PackageConfig :: Bool
enableTests = Bool
True
        , $sel:enableBenchmarks:PackageConfig :: Bool
enableBenchmarks = Bool
True
        , $sel:flags:PackageConfig :: Map FlagName Bool
flags =
            BuildOptsCLI -> PackageName -> Map FlagName Bool
getLocalFlags BuildOptsCLI
buildOptsCLI PackageName
name Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map FlagName Bool
sourceMapFlags
        , $sel:ghcOptions:PackageConfig :: [Text]
ghcOptions = [Text]
sourceMapGhcOptions
        , $sel:cabalConfigOpts:PackageConfig :: [Text]
cabalConfigOpts = [Text]
sourceMapCabalConfigOpts
        , $sel:compilerVersion:PackageConfig :: ActualCompiler
compilerVersion = ActualCompiler
compilerVersion
        , $sel:platform:PackageConfig :: Platform
platform = Getting Platform EnvConfig Platform -> EnvConfig -> Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform EnvConfig Platform
forall env. HasPlatform env => Lens' env Platform
Lens' EnvConfig Platform
platformL EnvConfig
econfig
        }
  -- TODO we've already parsed this information, otherwise we wouldn't have

  -- figured out the cabalFP already. In the future: retain that

  -- GenericPackageDescription in the relevant data structures to avoid

  -- reparsing.

  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
_cabalFP) <-
    Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP)
  GenericPackageDescription
gpkgdesc <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings

  -- Source the package's *.buildinfo file created by configure if any. See

  -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters

  Path Rel File
buildinfofp <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (PackageName -> String
packageNameString PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".buildinfo")
  Bool
hasDotBuildinfo <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
  let mbuildinfofp :: Maybe (Path Abs File)
mbuildinfofp
        | Bool
hasDotBuildinfo = Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
        | Bool
otherwise = Maybe (Path Abs File)
forall a. Maybe a
Nothing
  Maybe HookedBuildInfo
mbuildinfo <- Maybe (Path Abs File)
-> (Path Abs File -> RIO env HookedBuildInfo)
-> RIO env (Maybe HookedBuildInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Path Abs File)
mbuildinfofp Path Abs File -> RIO env HookedBuildInfo
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m HookedBuildInfo
readDotBuildinfo
  let pdp :: PackageDescription
pdp = PackageConfig -> GenericPackageDescription -> PackageDescription
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpkgdesc
      package :: Package
package =
        PackageConfig -> [PackageFlag] -> PackageDescription -> Package
packageFromPackageDescription PackageConfig
config (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpkgdesc) (PackageDescription -> Package) -> PackageDescription -> Package
forall a b. (a -> b) -> a -> b
$
          PackageDescription
-> (HookedBuildInfo -> PackageDescription)
-> Maybe HookedBuildInfo
-> PackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PackageDescription
pdp (HookedBuildInfo -> PackageDescription -> PackageDescription
`C.updatePackageDescription` PackageDescription
pdp) Maybe HookedBuildInfo
mbuildinfo
  GhciPkgDesc -> RIO env GhciPkgDesc
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgDesc
    { Package
$sel:package:GhciPkgDesc :: Package
package :: Package
package
    , Path Abs File
$sel:cabalFP:GhciPkgDesc :: Path Abs File
cabalFP :: Path Abs File
cabalFP
    , Target
$sel:target:GhciPkgDesc :: Target
target :: Target
target
    }

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

-- | Make information necessary to load the given package in GHCi.

makeGhciPkgInfo ::
     HasEnvConfig env
  => InstallMap
  -> InstalledMap
  -> [PackageName]
  -> [PackageName]
  -> Maybe (Map PackageName [Path Abs File])
  -> GhciPkgDesc
  -> RIO env GhciPkgInfo
makeGhciPkgInfo :: forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc = do
  BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
  let pkg :: Package
pkg = GhciPkgDesc
pkgDesc.package
      cabalFP :: Path Abs File
cabalFP = GhciPkgDesc
pkgDesc.cabalFP
      target :: Target
target = GhciPkgDesc
pkgDesc.target
      name :: PackageName
name = Package
pkg.name
  (Map NamedComponent (Map ModuleName (Path Abs File))
mods, Map NamedComponent [DotCabalPath]
files, Map NamedComponent BuildInfoOpts
opts) <-
    Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO
     env
     (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath],
      Map NamedComponent BuildInfoOpts)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m,
 MonadUnliftIO m) =>
Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> m (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath],
      Map NamedComponent BuildInfoOpts)
getPackageOpts Package
pkg InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Path Abs File
cabalFP
  let filteredOpts :: Map NamedComponent BuildInfoOpts
filteredOpts = Map NamedComponent BuildInfoOpts
-> Map NamedComponent BuildInfoOpts
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
      filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = (NamedComponent -> a -> Bool)
-> Map NamedComponent a -> Map NamedComponent a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
allWanted)
      allWanted :: Set NamedComponent
allWanted = BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target Package
pkg
  GhciPkgInfo -> RIO env GhciPkgInfo
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgInfo
    { PackageName
$sel:name:GhciPkgInfo :: PackageName
name :: PackageName
name
    , $sel:opts:GhciPkgInfo :: [(NamedComponent, BuildInfoOpts)]
opts = Map NamedComponent BuildInfoOpts
-> [(NamedComponent, BuildInfoOpts)]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
    , $sel:dir:GhciPkgInfo :: Path Abs Dir
dir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP
    , $sel:modules:GhciPkgInfo :: ModuleMap
modules = [ModuleMap] -> ModuleMap
unionModuleMaps ([ModuleMap] -> ModuleMap) -> [ModuleMap] -> ModuleMap
forall a b. (a -> b) -> a -> b
$
        ((NamedComponent, Map ModuleName (Path Abs File)) -> ModuleMap)
-> [(NamedComponent, Map ModuleName (Path Abs File))]
-> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> (Path Abs File
 -> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> Map ModuleName (Path Abs File) -> ModuleMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map
              (\Path Abs File
fp -> Path Abs File
-> Set (PackageName, NamedComponent)
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp ((PackageName, NamedComponent) -> Set (PackageName, NamedComponent)
forall a. a -> Set a
S.singleton (Package
pkg.name, NamedComponent
comp)))
              Map ModuleName (Path Abs File)
mp
          )
          (Map NamedComponent (Map ModuleName (Path Abs File))
-> [(NamedComponent, Map ModuleName (Path Abs File))]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent (Map ModuleName (Path Abs File))
-> Map NamedComponent (Map ModuleName (Path Abs File))
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
    , $sel:mainIs:GhciPkgInfo :: Map NamedComponent [Path Abs File]
mainIs = ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
    , $sel:cFiles:GhciPkgInfo :: [Path Abs File]
cFiles = [[Path Abs File]] -> [Path Abs File]
forall a. Monoid a => [a] -> a
mconcat
        (Map NamedComponent [Path Abs File] -> [[Path Abs File]]
forall k a. Map k a -> [a]
M.elems (Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted (([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath) Map NamedComponent [DotCabalPath]
files)))
    , $sel:targetFiles:GhciPkgInfo :: Maybe [Path Abs File]
targetFiles = Maybe (Map PackageName [Path Abs File])
mfileTargets Maybe (Map PackageName [Path Abs File])
-> (Map PackageName [Path Abs File] -> Maybe [Path Abs File])
-> Maybe [Path Abs File]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageName
-> Map PackageName [Path Abs File] -> Maybe [Path Abs File]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name
    , $sel:package:GhciPkgInfo :: Package
package = Package
pkg
    }

-- NOTE: this should make the same choices as the components code in

-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic

-- (differently).

wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
_ (TargetComps Set NamedComponent
cs) Package
_ = Set NamedComponent
cs
wantedPackageComponents BuildOpts
bopts (TargetAll PackageType
PTProject) Package
pkg = [NamedComponent] -> Set NamedComponent
forall a. Ord a => [a] -> Set a
S.fromList ([NamedComponent] -> Set NamedComponent)
-> [NamedComponent] -> Set NamedComponent
forall a b. (a -> b) -> a -> b
$
     ( if Package -> Bool
hasBuildableMainLibrary Package
pkg
         then NamedComponent
CLib NamedComponent -> [NamedComponent] -> [NamedComponent]
forall a. a -> [a] -> [a]
: (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CSubLib [Text]
buildableForeignLibs'
         else []
     )
  [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe [Text]
buildableExes'
  [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CSubLib [Text]
buildableSubLibs
  [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (if BuildOpts
bopts.tests then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest [Text]
buildableTestSuites else [])
  [NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (if BuildOpts
bopts.benchmarks then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench [Text]
buildableBenchmarks else [])
 where
  buildableForeignLibs' :: [Text]
buildableForeignLibs' = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
buildableForeignLibs Package
pkg
  buildableSubLibs :: [Text]
buildableSubLibs = CompCollection StackLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.subLibraries
  buildableExes' :: [Text]
buildableExes' = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
buildableExes Package
pkg
  buildableTestSuites :: [Text]
buildableTestSuites = CompCollection StackTestSuite -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.testSuites
  buildableBenchmarks :: [Text]
buildableBenchmarks = CompCollection StackBenchmark -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.benchmarks
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = Set NamedComponent
forall a. Set a
S.empty

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

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

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

-- module name?

checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs =
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"Multiple files use the same module name:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))
 -> StyleDoc)
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName,
 Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    -- MSS 2020-10-13 Disabling, may remove entirely in the future

    -- See: https://github.com/commercialhaskell/stack/issues/5407#issuecomment-707339928

    -- throwM LoadingDuplicateModules

 where
  duplicates ::
    [(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))]
  duplicates :: [(ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates =
    ((ModuleName,
  Map (Path Abs File) (Set (PackageName, NamedComponent)))
 -> Bool)
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ModuleName
_, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) -> Map (Path Abs File) (Set (PackageName, NamedComponent)) -> Int
forall k a. Map k a -> Int
M.size Map (Path Abs File) (Set (PackageName, NamedComponent))
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([(ModuleName,
   Map (Path Abs File) (Set (PackageName, NamedComponent)))]
 -> [(ModuleName,
      Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
    ModuleMap
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall k a. Map k a -> [(k, a)]
M.toList (ModuleMap
 -> [(ModuleName,
      Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> ModuleMap
-> [(ModuleName,
     Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
    [ModuleMap] -> ModuleMap
unionModuleMaps ((GhciPkgInfo -> ModuleMap) -> [GhciPkgInfo] -> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map (.modules) [GhciPkgInfo]
pkgs)
  prettyDuplicate ::
       (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))
    -> StyleDoc
  prettyDuplicate :: (ModuleName,
 Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate (ModuleName
mn, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) =
       [StyleDoc] -> StyleDoc
fillSep
         [ Style -> StyleDoc -> StyleDoc
style Style
Error (ModuleName -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn)
         , String -> StyleDoc
flow String
"found at the following paths"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc)
-> [(Path Abs File, Set (PackageName, NamedComponent))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Map (Path Abs File) (Set (PackageName, NamedComponent))
-> [(Path Abs File, Set (PackageName, NamedComponent))]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) (Set (PackageName, NamedComponent))
mp))
  fileDuplicate ::
    (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
  fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Path Abs File
fp, Set (PackageName, NamedComponent)
comps) =
    [StyleDoc] -> StyleDoc
fillSep
      [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
      , StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
          [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (Set (PackageName, NamedComponent)
-> [(PackageName, NamedComponent)]
forall a. Set a -> [a]
S.toList Set (PackageName, NamedComponent)
comps))
      ]

targetWarnings ::
     HasBuildConfig env
  => [(PackageName, (Path Abs File, Target))]
  -> [PackageName]
  -> Maybe (Map PackageName [Path Abs File], [Path Abs File])
  -> RIO env ()
targetWarnings :: forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
nonLocalTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ String -> StyleDoc
flow String
"Some targets"
      , StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," ([StyleDoc] -> [StyleDoc]) -> [StyleDoc] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
          (Style -> StyleDoc -> StyleDoc
style Style
Good (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName)
          [PackageName]
nonLocalTargets
      , String -> StyleDoc
flow String
"are not local packages, and so cannot be directly loaded. In \
             \future versions of Stack, this might be supported - see"
      , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1441"
      , StyleDoc
"."
      , String -> StyleDoc
flow String
"It can still be useful to specify these, as they will be passed \
             \to ghci via -package flags."
      ]
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& Maybe (Map PackageName [Path Abs File], [Path Abs File]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    SMWanted
smWanted <- Getting SMWanted env SMWanted -> RIO env SMWanted
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SMWanted env SMWanted -> RIO env SMWanted)
-> Getting SMWanted env SMWanted -> RIO env SMWanted
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const SMWanted BuildConfig)
 -> env -> Const SMWanted env)
-> ((SMWanted -> Const SMWanted SMWanted)
    -> BuildConfig -> Const SMWanted BuildConfig)
-> Getting SMWanted env SMWanted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> SMWanted) -> SimpleGetter BuildConfig SMWanted
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted)
    Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
Lens' env (Path Abs File)
stackYamlL
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
      [ String -> StyleDoc
flow String
"No local targets specified, so a plain ghci will be started with \
             \no package hiding or package options."
      , StyleDoc
""
      , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"You are using snapshot: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
               RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SMWanted
smWanted.snapshotLocation
      , 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"
              , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
              , String -> StyleDoc
flow String
"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"
          , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
          , String -> StyleDoc
flow String
"then you can add to its 'packages' field."
          ]
      , StyleDoc
""
      ]

-- Adds in intermediate dependencies between ghci targets. Note that it will

-- return a Lib component for these intermediate dependencies even if they don't

-- have a library (but that's fine for the usage within this module).

--

-- If 'True' is passed for loadAllDeps, this loads all local deps, even if they

-- aren't intermediate.

getExtraLoadDeps ::
     Bool
  -> Map PackageName LocalPackage
  -> [(PackageName, (Path Abs File, Target))]
  -> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps :: Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps Bool
loadAllDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
targets =
  Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall k a. Map k a -> [(k, a)]
M.toList (Map PackageName (Path Abs File, Target)
 -> [(PackageName, (Path Abs File, Target))])
-> Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
  (\Map PackageName (Path Abs File, Target)
mp -> (Map PackageName (Path Abs File, Target)
 -> PackageName -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> [PackageName]
-> Map PackageName (Path Abs File, Target)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((PackageName
 -> Map PackageName (Path Abs File, Target)
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> PackageName
-> Map PackageName (Path Abs File, Target)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map PackageName (Path Abs File, Target)
mp (((PackageName, (Path Abs File, Target)) -> PackageName)
-> [(PackageName, (Path Abs File, Target))] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst [(PackageName, (Path Abs File, Target))]
targets)) (Map PackageName (Path Abs File, Target)
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
  (Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> a
id (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
  State (Map PackageName (Maybe (Path Abs File, Target))) ()
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall s a. State s a -> s -> s
execState (((PackageName, (Path Abs File, Target))
 -> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> [(PackageName, (Path Abs File, Target))]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PackageName
 -> StateT
      (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go ([PackageName]
 -> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> ((PackageName, (Path Abs File, Target)) -> [PackageName])
-> (PackageName, (Path Abs File, Target))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [PackageName]
getDeps (PackageName -> [PackageName])
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
targets)
            ([(PackageName, Maybe (Path Abs File, Target))]
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((PackageName, (Path Abs File, Target))
 -> (PackageName, Maybe (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Maybe (Path Abs File, Target))]
forall a b. (a -> b) -> [a] -> [b]
map (((Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> (PackageName, (Path Abs File, Target))
-> (PackageName, Maybe (Path Abs File, Target))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just) [(PackageName, (Path Abs File, Target))]
targets))
 where
  getDeps :: PackageName -> [PackageName]
  getDeps :: PackageName -> [PackageName]
getDeps PackageName
name =
    case PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap of
      Just LocalPackage
lp -> Package -> [PackageName]
listOfPackageDeps LocalPackage
lp.package -- FIXME just Local?

      Maybe LocalPackage
_ -> []
  go ::
       PackageName
    -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
  go :: PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go PackageName
name = do
    Map PackageName (Maybe (Path Abs File, Target))
cache <- StateT
  (Map PackageName (Maybe (Path Abs File, Target)))
  Identity
  (Map PackageName (Maybe (Path Abs File, Target)))
forall s (m :: * -> *). MonadState s m => m s
get
    case (PackageName
-> Map PackageName (Maybe (Path Abs File, Target))
-> Maybe (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Maybe (Path Abs File, Target))
cache, PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap) of
      (Just (Just (Path Abs File, Target)
_), Maybe LocalPackage
_) -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      (Just Maybe (Path Abs File, Target)
Nothing, Maybe LocalPackage
_) | Bool -> Bool
not Bool
loadAllDeps -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      (Maybe (Maybe (Path Abs File, Target))
_, Just LocalPackage
lp) -> do
        let deps :: [PackageName]
deps = Package -> [PackageName]
listOfPackageDeps LocalPackage
lp.package
        Bool
shouldLoad <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName
 -> StateT
      (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PackageName
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go [PackageName]
deps
        if Bool
shouldLoad
          then do
            (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name ((Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just (LocalPackage
lp.cabalFP, Set NamedComponent -> Target
TargetComps (NamedComponent -> Set NamedComponent
forall a. a -> Set a
S.singleton NamedComponent
CLib))))
            Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else do
            (Map PackageName (Maybe (Path Abs File, Target))
 -> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name Maybe (Path Abs File, Target)
forall a. Maybe a
Nothing)
            Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      (Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> Bool
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
     (Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

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

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