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

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


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

import           Control.Monad.State.Strict ( State, execState, get, modify )
import           Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import           Data.Foldable ( foldl )
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Distribution.PackageDescription as C
import           Path
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO hiding ( withSystemTempDir )
import           RIO.Process
                   ( HasProcessContext, exec, proc, readProcess_
                   , withWorkingDir
                   )
import           Stack.Build
import           Stack.Build.Installed
import           Stack.Build.Source
import           Stack.Build.Target
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Ghci.Script
import           Stack.Package
import           Stack.Prelude
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.PackageFile
import           Stack.Types.SourceMap
import           System.IO ( putStrLn )
import           System.IO.Temp ( getCanonicalTemporaryDirectory )
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
    | GhciTargetParseException [Text]
    deriving (Int -> GhciException -> ShowS
[GhciException] -> ShowS
GhciException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciException] -> ShowS
$cshowList :: [GhciException] -> ShowS
show :: GhciException -> String
$cshow :: GhciException -> String
showsPrec :: Int -> GhciException -> ShowS
$cshowsPrec :: Int -> GhciException -> ShowS
Show, Typeable)

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

-- | Command-line options for GHC.

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

-- | Necessary information to load a package or its components.

--

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

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

data GhciPkgInfo = GhciPkgInfo
    { GhciPkgInfo -> PackageName
ghciPkgName :: !PackageName
    , GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]
    , GhciPkgInfo -> Path Abs Dir
ghciPkgDir :: !(Path Abs Dir)
    , GhciPkgInfo -> ModuleMap
ghciPkgModules :: !ModuleMap
    , GhciPkgInfo -> [Path Abs File]
ghciPkgCFiles :: ![Path Abs File] -- ^ C files.

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

-- | Loaded package description and related info.

data GhciPkgDesc = GhciPkgDesc
    { GhciPkgDesc -> Package
ghciDescPkg :: !Package
    , GhciPkgDesc -> Path Abs File
ghciDescCabalFp :: !(Path Abs File)
    , GhciPkgDesc -> Target
ghciDescTarget :: !Target
    }

-- Mapping from a module name to a map with all of the paths that use

-- that name. Each of those paths is associated with a set of components

-- that contain it. Purpose of this complex structure is for use in

-- 'checkForDuplicateModules'.

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

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

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

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

-- of those targets.

ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci :: forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci opts :: GhciOpts
opts@GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} = do
    let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
            { boptsCLITargets :: [Text]
boptsCLITargets = []
            , boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags
            }
    SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    [LocalPackage]
depLocals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
    let localMap :: Map PackageName LocalPackage
localMap =
          forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Package -> PackageName
packageName forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals forall a. [a] -> [a] -> [a]
++ [LocalPackage]
depLocals]
        -- FIXME:qrilka this looks wrong to go back to SMActual

        sma :: SMActual GlobalPackage
sma = SMActual
             { smaCompiler :: ActualCompiler
smaCompiler = SourceMap -> ActualCompiler
smCompiler SourceMap
sourceMap
             , smaProject :: Map PackageName ProjectPackage
smaProject = SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap
             , smaDeps :: Map PackageName DepPackage
smaDeps = SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap
             , smaGlobal :: Map PackageName GlobalPackage
smaGlobal = SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap
             }
    -- Parse --main-is argument.

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

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

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

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

    [PackageName]
nonLocalTargets <- forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
    -- Check if additional package arguments are sensible.

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

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

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

              -- about which main module to load. See the note below for

              -- why this is done again after the build. This could

              -- potentially be done more efficiently, because all we

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

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

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

    -- unlisted dependencies (#1180)

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

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

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

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

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

            let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text]
normalTargetsRaw }
            SMTargets
normalTargets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
                forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BuildException
ex -> case BuildException
ex of
                    TargetParseException [Text]
xs -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Text] -> GhciException
GhciTargetParseException [Text]
xs)
                    BuildException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BuildException
ex
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SMTargets -> Map PackageName Target
smtTargets SMTargets
normalTargets)

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

-- | Display PackageName + NamedComponent

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

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

getAllLocalTargets ::
       HasEnvConfig env
    => GhciOpts
    -> Map PackageName Target
    -> Maybe (Map PackageName Target)
    -> Map PackageName LocalPackage
    -> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets :: forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
    -- Use the 'mainIsTargets' as normal targets, for CLI concision. See

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

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

    -- specified.

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

    -- targets.

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

    let extraLoadDeps :: [(PackageName, (Path Abs File, Target))]
extraLoadDeps = Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps Bool
ghciLoadLocalDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
directlyWanted
    if (Bool
ghciSkipIntermediate Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ghciLoadLocalDeps) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
        else do
            let extraList :: Utf8Builder
extraList =
                  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps)
            if Bool
ghciLoadLocalDeps
                then forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"The following libraries will also be loaded into GHCi because " forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"they are local dependencies of your targets, and you specified --load-local-deps:\n    " forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
extraList
                else forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"The following libraries will also be loaded into GHCi because " forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"they are intermediate dependencies of your targets:\n    " forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
extraList forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"\n(Use --skip-intermediate-deps to omit these)"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)

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

buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [Text]
localTargets = do
    let targets :: [Text]
targets = [Text]
localTargets forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
ghciAdditionalPackages
    -- If necessary, do the build, for local packagee targets, only do

    -- 'initialBuildSteps'.

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

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

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

runGhci ::
       HasEnvConfig env
    => GhciOpts
    -> [(PackageName, (Path Abs File, Target))]
    -> Maybe (Path Abs File)
    -> [GhciPkgInfo]
    -> [Path Abs File]
    -> [PackageName]
    -> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [(PackageName, (Path Abs File, Target))]
targets Maybe (Path Abs File)
mainFile [GhciPkgInfo]
pkgs [Path Abs File]
extraFiles [PackageName]
exposePackages = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let pkgopts :: [String]
pkgopts = [String]
hidePkgOpts forall a. [a] -> [a] -> [a]
++ [String]
genOpts forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
        shouldHidePackages :: Bool
shouldHidePackages =
          forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages)) Maybe Bool
ghciHidePackages
        hidePkgOpts :: [String]
hidePkgOpts =
          if Bool
shouldHidePackages
            then
              [String
"-hide-all-packages"] forall a. [a] -> [a] -> [a]
++
              -- This is necessary, because current versions of ghci

              -- will entirely fail to start if base isn't visible. This

              -- is because it tries to use the interpreter to set

              -- buffering options on standard IO.

              (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else []) forall a. [a] -> [a] -> [a]
++
              forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\PackageName
n -> [String
"-package", PackageName -> String
packageNameString PackageName
n]) [PackageName]
exposePackages
            else []
        oneWordOpts :: BuildInfoOpts -> [String]
oneWordOpts BuildInfoOpts
bio
            | Bool
shouldHidePackages = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioPackageFlags BuildInfoOpts
bio
            | Bool
otherwise = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio
        genOpts :: [String]
genOpts = forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
oneWordOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs)
        ([String]
omittedOpts, [String]
ghcOpts) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition String -> Bool
badForGhci forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
bioOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
              ( forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config) -- include everything, locals, and targets

             forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs
              )
        getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PackageName
pkg (Config -> Map PackageName [Text]
configGhcOptionsByName Config
config)
        badForGhci :: String -> Bool
badForGhci String
x =
            forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"-O" String
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
            (Utf8Builder
"The following GHC options are incompatible with GHCi and have not been passed to it: " forall a. Semigroup a => a -> a -> a
<>
             forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
" " (forall a. IsString a => String -> a
fromString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts)))
    Path Abs Dir
oiDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
    let odir :: [String]
odir =
            [ String
"-odir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
            , String
"-hidir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir ]
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
      Utf8Builder
"Configuring GHCi with the following packages: " forall a. Semigroup a => a -> a -> a
<>
      forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs))
    String
compilerExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompilerforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to forall b t. Path b t -> String
toFilePath
    let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
            ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
            forall {a}. RIO env a -> RIO env a
withPackageWorkingDir forall a b. (a -> b) -> a -> b
$ forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
                 (forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand)
                 ((String
"--interactive" forall a. a -> [a] -> [a]
: ) forall a b. (a -> b) -> a -> b
$
                 -- This initial "-i" resets the include directories to

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

                 -- is included.

                  (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then forall a. a -> a
id else (String
"-i" forall a. a -> [a] -> [a]
: )) forall a b. (a -> b) -> a -> b
$
                  [String]
odir forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts forall a. Semigroup a => a -> a -> a
<> [String]
extras forall a. Semigroup a => a -> a -> a
<> [String]
ghciGhcOptions forall a. Semigroup a => a -> a -> a
<> [String]
ghciArgs)
        withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
            case [GhciPkgInfo]
pkgs of
              [GhciPkgInfo
pkg] -> forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
              [GhciPkgInfo]
_ -> forall a. a -> a
id
        -- TODO: Consider optimizing this check. Perhaps if no

        -- "with-ghc" is specified, assume that it is not using intero.

        checkIsIntero :: RIO env Bool
checkIsIntero =
            -- Optimization dependent on the behavior of renderScript -

            -- it doesn't matter if it's intero or ghci when loading

            -- multiple packages.

            case [GhciPkgInfo]
pkgs of
                [GhciPkgInfo
_] -> do
                    ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
                    String
output <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
                            forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine (forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand) [String
"--version"]
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Intero" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
output
                [GhciPkgInfo]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    -- Since usage of 'exec' does not pure, we cannot do any cleanup

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

    -- more efficient and avoid gratuitous generation of garbage, the

    -- file names are determined by hashing. This also has the nice side

    -- effect of making it possible to copy the ghci invocation out of

    -- the log and have it still work.

    Path Abs Dir
tmpDirectory <-
        (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirHaskellStackGhci) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCanonicalTemporaryDirectory)
    Path Abs Dir
ghciDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
    [String]
macrosOptions <- forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
    if Bool
ghciNoLoadModules
        then forall {b}. [String] -> RIO env b
execGhci [String]
macrosOptions
        else do
            forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
            Bool
isIntero <- RIO env Bool
checkIsIntero
            [String]
scriptOptions <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
tmpDirectory (Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
ghciOnlyMain [Path Abs File]
extraFiles)
            forall {b}. [String] -> RIO env b
execGhci ([String]
macrosOptions forall a. [a] -> [a] -> [a]
++ [String]
scriptOptions)

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

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

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

renderScript ::
     Bool
  -> [GhciPkgInfo]
  -> Maybe (Path Abs File)
  -> Bool
  -> [Path Abs File]
  -> GhciScript
renderScript :: Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
    let cdPhase :: GhciScript
cdPhase = case (Bool
isIntero, [GhciPkgInfo]
pkgs) of
          -- If only loading one package, set the cwd properly.

          -- Otherwise don't try. See

          -- https://github.com/commercialhaskell/stack/issues/3309

          (Bool
True, [GhciPkgInfo
pkg]) -> Path Abs Dir -> GhciScript
cmdCdGhc (GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
          (Bool, [GhciPkgInfo])
_ -> forall a. Monoid a => a
mempty
        addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ModuleName]
allModules forall a. [a] -> [a] -> [a]
++ forall {a}. [Either a (Path Abs File)]
addMain)
        addMain :: [Either a (Path Abs File)]
addMain = case Maybe (Path Abs File)
mainFile of
            Just Path Abs File
path -> [forall a b. b -> Either a b
Right Path Abs File
path]
            Maybe (Path Abs File)
_ -> []
        modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
        allModules :: [ModuleName]
allModules = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> ModuleMap
ghciPkgModules) [GhciPkgInfo]
pkgs
    case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
        [] ->
          if Bool
onlyMain
            then GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> if forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList forall {a}. [Either a (Path Abs File)]
addMain) else forall a. Monoid a => a
mempty
            else GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
addPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
        [Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))

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

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

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

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

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

figureOutMainFile ::
       HasRunner env
    => BuildOpts
    -> Maybe (Map PackageName Target)
    -> [(PackageName, (Path Abs File, Target))]
    -> [GhciPkgInfo]
    -> RIO env (Maybe (Path Abs File))
figureOutMainFile :: forall env.
HasRunner env =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
targets0 [GhciPkgInfo]
packages = do
    case [(PackageName, NamedComponent, Path Abs File)]
candidates of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        [c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Using main module: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ((PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate (PackageName, NamedComponent, Path Abs File)
c))
                           forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
fp)
        (PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
          forall env a. HasLogFunc env => RIO env a -> RIO env a
borderedWarning forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"The main module to load is ambiguous. Candidates are: "
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates) (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                Utf8Builder
"You can specify which one to pick by: "
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Specifying targets to stack ghci e.g. stack ghci " forall a. Semigroup a => a -> a -> a
<>
                forall a. Display a => a -> Utf8Builder
display ( forall {c}. (PackageName, NamedComponent, c) -> Text
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate))
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Specifying what the main is e.g. stack ghci " forall a. Semigroup a => a -> a -> a
<>
                 forall a. Display a => a -> Utf8Builder
display (forall {c}. (PackageName, NamedComponent, c) -> Text
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate))
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                (Utf8Builder
" * Choosing from the candidate above [1.." forall a. Semigroup a => a -> a -> a
<>
                forall a. Display a => a -> Utf8Builder
display (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"]")
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
  where
    targets :: Map PackageName Target
targets = forall a. a -> Maybe a -> a
fromMaybe (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
k, (Path Abs File
_, Target
x)) -> (PackageName
k, Target
x)) [(PackageName, (Path Abs File, Target))]
targets0)
                        Maybe (Map PackageName Target)
mainIsTargets
    candidates :: [(PackageName, NamedComponent, Path Abs File)]
candidates = do
        GhciPkgInfo
pkg <- [GhciPkgInfo]
packages
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg) Map PackageName Target
targets of
            Maybe Target
Nothing -> []
            Just Target
target -> do
                (NamedComponent
component,[Path Abs File]
mains) <-
                    forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
                    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
wantedComponents)
                                    (GhciPkgInfo -> Map NamedComponent [Path Abs File]
ghciPkgMainIs GhciPkgInfo
pkg)
                Path Abs File
main <- [Path Abs File]
mains
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg, NamedComponent
component, Path Abs File
main)
              where
                wantedComponents :: Set NamedComponent
wantedComponents =
                    BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target (GhciPkgInfo -> Package
ghciPkgPackage GhciPkgInfo
pkg)
    renderCandidate :: (PackageName, NamedComponent, Path Abs File) -> Text
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName,NamedComponent
namedComponent,Path Abs File
mainIs) =
        let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> Text
candidateIndex = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
            pkgNameText :: Text
pkgNameText = String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkgName)
        in  [(PackageName, NamedComponent, Path Abs File)] -> Text
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates forall a. Semigroup a => a -> a -> a
<> Text
". Package `" forall a. Semigroup a => a -> a -> a
<>
            Text
pkgNameText forall a. Semigroup a => a -> a -> a
<>
            Text
"' component " forall a. Semigroup a => a -> a -> a
<>
            -- This is the format that can be directly copy-pasted as

            -- an argument to `stack ghci`.

            Text
pkgNameText forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
namedComponent forall a. Semigroup a => a -> a -> a
<>
            Text
" with main-is file: " forall a. Semigroup a => a -> a -> a
<>
            String -> Text
T.pack (forall b t. Path b t -> String
toFilePath Path Abs File
mainIs)
    candidateIndices :: [Int]
candidateIndices = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) [Int
1 :: Int ..]
    userOption :: IO (Maybe (Path Abs File))
userOption = do
      Text
option <- forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
      let selected :: Int
selected = forall a. a -> Maybe a -> a
fromMaybe
                      ((forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
                      (forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
      case forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
selected [Int]
candidateIndices  of
        Maybe Int
Nothing -> do
            String -> IO ()
putStrLn
              String
"Not loading any main modules, as no valid module selected"
            String -> IO ()
putStrLn String
""
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Int
op -> do
            let (PackageName
_,NamedComponent
_,Path Abs File
fp) = [(PackageName, NamedComponent, Path Abs File)]
candidates forall a. [a] -> Int -> a
L.!! Int
op
            String -> IO ()
putStrLn
              (String
"Loading main module from candidate " forall a. Semigroup a => a -> a -> a
<>
              forall a. Show a => a -> String
show (Int
op forall a. Num a => a -> a -> a
+ Int
1) forall a. Semigroup a => a -> a -> a
<> String
", --main-is " forall a. Semigroup a => a -> a -> a
<>
              forall b t. Path b t -> String
toFilePath Path Abs File
fp)
            String -> IO ()
putStrLn String
""
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
fp
    renderComp :: NamedComponent -> Text
renderComp NamedComponent
c =
        case NamedComponent
c of
            NamedComponent
CLib -> Text
"lib"
            CInternalLib Text
name -> Text
"internal-lib:" forall a. Semigroup a => a -> a -> a
<> Text
name
            CExe Text
name -> Text
"exe:" forall a. Semigroup a => a -> a -> a
<> Text
name
            CTest Text
name -> Text
"test:" forall a. Semigroup a => a -> a -> a
<> Text
name
            CBench Text
name -> Text
"bench:" forall a. Semigroup a => a -> a -> a
<> Text
name
    sampleTargetArg :: (PackageName, NamedComponent, c) -> Text
sampleTargetArg (PackageName
pkg,NamedComponent
comp,c
_) =
        String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkg) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
comp
    sampleMainIsArg :: (PackageName, NamedComponent, c) -> Text
sampleMainIsArg (PackageName
pkg,NamedComponent
comp,c
_) =
        Text
"--main-is " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pkg) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> NamedComponent -> Text
renderComp NamedComponent
comp

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

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

loadGhciPkgDesc ::
       HasEnvConfig env
    => BuildOptsCLI
    -> PackageName
    -> Path Abs File
    -> Target
    -> RIO env GhciPkgDesc
loadGhciPkgDesc :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalfp Target
target = do
    EnvConfig
econfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
    ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
    let SourceMap{Map PackageName GlobalPackage
Map PackageName ProjectPackage
Map PackageName DepPackage
ActualCompiler
SMTargets
smTargets :: SourceMap -> SMTargets
smGlobal :: Map PackageName GlobalPackage
smDeps :: Map PackageName DepPackage
smProject :: Map PackageName ProjectPackage
smCompiler :: ActualCompiler
smTargets :: SMTargets
smGlobal :: SourceMap -> Map PackageName GlobalPackage
smDeps :: SourceMap -> Map PackageName DepPackage
smProject :: SourceMap -> Map PackageName ProjectPackage
smCompiler :: SourceMap -> ActualCompiler
..} = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
econfig
        -- Currently this source map is being build with

        -- the default targets

        sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
          (CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
        sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
          (CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
        sourceMapFlags :: Map FlagName Bool
sourceMapFlags = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (CommonPackage -> Map FlagName Bool
cpFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject
        config :: PackageConfig
config =
            PackageConfig
            { packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
True
            , packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
True
            , packageConfigFlags :: Map FlagName Bool
packageConfigFlags = BuildOptsCLI -> PackageName -> Map FlagName Bool
getLocalFlags BuildOptsCLI
buildOptsCLI PackageName
name forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map FlagName Bool
sourceMapFlags
            , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = [Text]
sourceMapGhcOptions
            , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = [Text]
sourceMapCabalConfigOpts
            , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
            , packageConfigPlatform :: Platform
packageConfigPlatform = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL EnvConfig
econfig
            }
    -- TODO we've already parsed this information, otherwise we

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

    -- retain that GenericPackageDescription in the relevant data

    -- structures to avoid reparsing.

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

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

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

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

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

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

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

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

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

-- (differently).

wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
_ (TargetComps Set NamedComponent
cs) Package
_ = Set NamedComponent
cs
wantedPackageComponents BuildOpts
bopts (TargetAll PackageType
PTProject) Package
pkg = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$
    (case Package -> PackageLibraries
packageLibraries Package
pkg of
       PackageLibraries
NoLibraries -> []
       HasLibraries Set Text
names -> NamedComponent
CLib forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList Set Text
names)) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageExes Package
pkg)) forall a. Semigroup a => a -> a -> a
<>
    forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
pkg) forall a. Semigroup a => a -> a -> a
<>
    (if BuildOpts -> Bool
boptsTests BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest (forall k a. Map k a -> [k]
M.keys (Package -> Map Text TestSuiteInterface
packageTests Package
pkg)) else []) forall a. Semigroup a => a -> a -> a
<>
    (if BuildOpts -> Bool
boptsBenchmarks BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageBenchmarks Package
pkg)) else [])
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = forall a. Set a
S.empty

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

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

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

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

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

        -- throwM LoadingDuplicateModules

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

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

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

-- will return a Lib component for these intermediate dependencies even

-- if they don't have a library (but that's fine for the usage within

-- this module).

--

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

-- if they aren't intermediate.

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

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

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

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

-- | Run a command and grab the first line of stdout, dropping

-- stderr's contexts completely.

runGrabFirstLine ::
     (HasProcessContext env, HasLogFunc env)
  => String
  -> [String]
  -> RIO env String
runGrabFirstLine :: forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine String
cmd0 [String]
args =
  forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
cmd0 [String]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> do
    (ByteString
out, ByteString
_err) <- forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack
      forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
TL.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')
      forall a b. (a -> b) -> a -> b
$ [Text] -> Text
TL.concat
      forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1
      forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines
      forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
lenientDecode ByteString
out