{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Ghci
( GhciOpts (..)
, GhciPkgInfo (..)
, GhciPrettyException (..)
, ModuleMap
, ghciCmd
, ghci
) where
import Control.Monad.Extra ( whenJust )
import Control.Monad.State.Strict ( State, execState, get, modify )
import Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as L
import Data.List.Extra ( (!?) )
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import Path ((</>), parent, parseRelFile )
import Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
import Path.IO
( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir )
import RIO.NonEmpty ( nonEmpty )
import RIO.Process ( exec, withWorkingDir )
import Stack.Build ( buildLocalTargets )
import Stack.Build.Installed ( getInstalled, toInstallMap )
import Stack.Build.Source ( localDependencies, projectLocalPackages )
import Stack.Build.Target ( NeedTargets (..), parseTargets )
import Stack.Constants
( relDirGhciScript, relDirStackProgName, relFileCabalMacrosH
, relFileGhciScript, stackProgName'
)
import Stack.Constants.Config ( ghciDirL, objectInterfaceDirL )
import Stack.Ghci.Script
( GhciScript, ModuleName, cmdAdd, cmdModule
, scriptToLazyByteString
)
import Stack.Package
( buildableExes, buildableForeignLibs, buildableSubLibs
, buildableTestSuites, buildableBenchmarks, getPackageOpts
, hasBuildableMainLibrary, listOfPackageDeps
, packageFromPackageDescription, readDotBuildinfo
, resolvePackageDescription, topSortPackageComponent
)
import Stack.PackageFile ( getPackageFile )
import Stack.Prelude
import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import Stack.Types.Build.Exception
( BuildPrettyException (..), pprintTargetParseErrors )
import Stack.Types.BuildConfig
( BuildConfig (..), HasBuildConfig (..), configFileL )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) )
import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) )
import Stack.Types.BuildOptsCLI
( ApplyCLIFlag (..), BuildOptsCLI (..), defaultBuildOptsCLI )
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..) )
import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import Stack.Types.Config.Exception ( ConfigPrettyException (..) )
import Stack.Types.EnvConfig
( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
, shaPathForBytes
)
import Stack.Types.EnvSettings ( defaultEnvSettings )
import Stack.Types.GhciOpts ( GhciOpts (..) )
import Stack.Types.Installed ( InstallMap, InstalledMap )
import Stack.Types.NamedComponent
( NamedComponent (..), isCLib, isCSubLib, renderComponentTo
, renderPkgComponent
)
import Stack.Types.Package
( BuildInfoOpts (..), LocalPackage (..), Package (..)
, PackageConfig (..), dotCabalCFilePath, dotCabalGetPath
, dotCabalMainPath
)
import Stack.Types.PackageFile ( PackageComponentFile (..) )
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Runner ( HasRunner, Runner )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), GlobalPackage
, PackageType (..), ProjectPackage (..), SMActual (..)
, SMTargets (..), SMWanted (..), SourceMap (..), Target (..)
)
import System.IO ( putStrLn )
import System.Permissions ( setScriptPerms )
data GhciPrettyException
= GhciTargetParseException ![StyleDoc]
| CandidatesIndexOutOfRangeBug
| InvalidPackageOption !String
| FileTargetIsInvalidAbsFile !String
| Can'tSpecifyFilesAndTargets
| Can'tSpecifyFilesAndMainIs
deriving (Int -> GhciPrettyException -> ShowS
[GhciPrettyException] -> ShowS
GhciPrettyException -> String
(Int -> GhciPrettyException -> ShowS)
-> (GhciPrettyException -> String)
-> ([GhciPrettyException] -> ShowS)
-> Show GhciPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciPrettyException -> ShowS
showsPrec :: Int -> GhciPrettyException -> ShowS
$cshow :: GhciPrettyException -> String
show :: GhciPrettyException -> String
$cshowList :: [GhciPrettyException] -> ShowS
showList :: [GhciPrettyException] -> ShowS
Show, Typeable)
instance Pretty GhciPrettyException where
pretty :: GhciPrettyException -> StyleDoc
pretty (GhciTargetParseException [StyleDoc]
errs) =
StyleDoc
"[S-6948]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Note that to specify options to be passed to GHCi, use the"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--ghci-options"
, StyleDoc
"option."
]
pretty GhciPrettyException
CandidatesIndexOutOfRangeBug = String -> StyleDoc -> StyleDoc
bugPrettyReport String
"[S-1939]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"figureOutMainFile: index out of range."
pretty (InvalidPackageOption String
name) =
StyleDoc
"[S-6716]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Failed to parse"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--package"
, StyleDoc
"option"
, Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
pretty (FileTargetIsInvalidAbsFile String
name) =
StyleDoc
"[S-3600]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Cannot work out a valid path for file target"
, Style -> StyleDoc -> StyleDoc
style Style
File (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
pretty GhciPrettyException
Can'tSpecifyFilesAndTargets =
StyleDoc
"[S-9906]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Cannot use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack ghci"
, String -> StyleDoc
flow String
"with both file targets and package targets."
]
pretty GhciPrettyException
Can'tSpecifyFilesAndMainIs =
StyleDoc
"[S-5188]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Cannot use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack ghci"
, String -> StyleDoc
flow String
"with both file targets and"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--main-is"
, StyleDoc
"flag."
]
instance Exception GhciPrettyException
data GhciPkgInfo = GhciPkgInfo
{ GhciPkgInfo -> PackageName
name :: !PackageName
, GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
opts :: ![(NamedComponent, BuildInfoOpts)]
, GhciPkgInfo -> Path Abs Dir
dir :: !(Path Abs Dir)
, GhciPkgInfo -> ModuleMap
modules :: !ModuleMap
, GhciPkgInfo -> [Path Abs File]
cFiles :: ![Path Abs File]
, GhciPkgInfo -> Map NamedComponent [Path Abs File]
mainIs :: !(Map NamedComponent [Path Abs File])
, GhciPkgInfo -> Maybe [Path Abs File]
targetFiles :: !(Maybe [Path Abs File])
, GhciPkgInfo -> Package
package :: !Package
}
deriving Int -> GhciPkgInfo -> ShowS
[GhciPkgInfo] -> ShowS
GhciPkgInfo -> String
(Int -> GhciPkgInfo -> ShowS)
-> (GhciPkgInfo -> String)
-> ([GhciPkgInfo] -> ShowS)
-> Show GhciPkgInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshow :: GhciPkgInfo -> String
show :: GhciPkgInfo -> String
$cshowList :: [GhciPkgInfo] -> ShowS
showList :: [GhciPkgInfo] -> ShowS
Show
data GhciPkgDesc = GhciPkgDesc
{ GhciPkgDesc -> Package
package :: !Package
, GhciPkgDesc -> Path Abs File
cabalFP :: !(Path Abs File)
, GhciPkgDesc -> Target
target :: !Target
}
type ModuleMap =
Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent)))
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps = (Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> [ModuleMap] -> ModuleMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith ((Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent)
-> Set (PackageName, NamedComponent)
forall a. Ord a => Set a -> Set a -> Set a
S.union)
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd GhciOpts
ghciOpts =
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ targetsCLI = map T.pack ghciOpts.additionalPackages
, initialBuildSteps = True
, flags = ghciOpts.flags
, ghcOptions = map T.pack ghciOpts.ghcOptions
}
in ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
BuildOpts
bopts <- Getting BuildOpts EnvConfig BuildOpts -> RIO EnvConfig BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts EnvConfig BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL
let boptsLocal :: BuildOpts
boptsLocal = BuildOpts
bopts
{ testOpts = bopts.testOpts { TestOpts.runTests = False }
, benchmarkOpts =
bopts.benchmarkOpts { BenchmarkOpts.runBenchmarks = False }
}
(EnvConfig -> EnvConfig) -> RIO EnvConfig () -> RIO EnvConfig ()
forall a.
(EnvConfig -> EnvConfig) -> RIO EnvConfig a -> RIO EnvConfig a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter EnvConfig EnvConfig BuildOpts BuildOpts
-> BuildOpts -> EnvConfig -> EnvConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter EnvConfig EnvConfig BuildOpts BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL BuildOpts
boptsLocal) (GhciOpts -> RIO EnvConfig ()
forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
ghciOpts)
ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci :: forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
opts = do
let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ targetsCLI = []
, flags = opts.flags
}
SourceMap
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
-> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap)
InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
[LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
[LocalPackage]
depLocals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
let localMap :: Map PackageName LocalPackage
localMap =
[(PackageName, LocalPackage)] -> Map PackageName LocalPackage
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(LocalPackage
lp.package.name, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals [LocalPackage] -> [LocalPackage] -> [LocalPackage]
forall a. [a] -> [a] -> [a]
++ [LocalPackage]
depLocals]
sma :: SMActual GlobalPackage
sma = SMActual
{ compiler :: ActualCompiler
compiler = SourceMap
sourceMap.compiler
, project :: Map PackageName ProjectPackage
project = SourceMap
sourceMap.project
, deps :: Map PackageName DepPackage
deps = SourceMap
sourceMap.deps
, globals :: Map PackageName GlobalPackage
globals = SourceMap
sourceMap.globalPkgs
}
Maybe (Map PackageName Target)
mainIsTargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma GhciOpts
opts.mainIs
Either [Path Abs File] (Map PackageName Target)
etargets <- BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma GhciOpts
opts.targets
(Map PackageName Target
inputTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) <- case Either [Path Abs File] (Map PackageName Target)
etargets of
Right Map PackageName Target
packageTargets -> (Map PackageName Target,
Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
env
(Map PackageName Target,
Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
packageTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. Maybe a
Nothing)
Left [Path Abs File]
rawFileTargets -> do
Maybe (Map PackageName Target)
-> (Map PackageName Target -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Map PackageName Target)
mainIsTargets ((Map PackageName Target -> RIO env ()) -> RIO env ())
-> (Map PackageName Target -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Map PackageName Target
_ -> GhciPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM GhciPrettyException
Can'tSpecifyFilesAndMainIs
(Map PackageName Target
targetMap, Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles) <- [LocalPackage]
-> [Path Abs File]
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
rawFileTargets
(Map PackageName Target,
Maybe (Map PackageName [Path Abs File], [Path Abs File]))
-> RIO
env
(Map PackageName Target,
Maybe (Map PackageName [Path Abs File], [Path Abs File]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
forall a. a -> Maybe a
Just (Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles))
[(PackageName, (Path Abs File, Target))]
localTargets <- GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
opts Map PackageName Target
inputTargets Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap
[PackageName]
nonLocalTargets <- Map PackageName Target -> RIO env [PackageName]
forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
let getInternalDependencies :: Target -> r -> Seq NamedComponent
getInternalDependencies Target
target r
localPackage =
Package -> Target -> Bool -> Seq NamedComponent
topSortPackageComponent r
localPackage.package Target
target Bool
False
internalDependencies :: Map PackageName (Seq NamedComponent)
internalDependencies =
(Target -> LocalPackage -> Seq NamedComponent)
-> Map PackageName Target
-> Map PackageName LocalPackage
-> Map PackageName (Seq NamedComponent)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Target -> LocalPackage -> Seq NamedComponent
forall {r}.
HasField "package" r Package =>
Target -> r -> Seq NamedComponent
getInternalDependencies Map PackageName Target
inputTargets Map PackageName LocalPackage
localMap
relevantDependencies :: Map PackageName (Seq NamedComponent)
relevantDependencies = (Seq NamedComponent -> Bool)
-> Map PackageName (Seq NamedComponent)
-> Map PackageName (Seq NamedComponent)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((NamedComponent -> Bool) -> Seq NamedComponent -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCSubLib) Map PackageName (Seq NamedComponent)
internalDependencies
[PackageName]
addPkgs <- [String] -> RIO env [PackageName]
forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages GhciOpts
opts.additionalPackages
[GhciPkgDesc]
pkgDescs <- BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets
BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
Maybe (Path Abs File)
mainFile <- if GhciOpts
opts.noLoadModules
then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
else do
[GhciPkgInfo]
pkgs0 <- InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (((Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File]
forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
localTargets [GhciPkgInfo]
pkgs0
let pkgTargets :: PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
targets =
case Target
targets of
TargetAll PackageType
_ -> [String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pn)]
TargetComps Set NamedComponent
comps -> [(PackageName, NamedComponent) -> Text
renderPkgComponent (PackageName
pn, NamedComponent
c) | NamedComponent
c <- Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps]
GhciOpts -> [Text] -> RIO env ()
forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
opts ([Text] -> RIO env ()) -> [Text] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
((PackageName, (Path Abs File, Target)) -> [Text])
-> [(PackageName, (Path Abs File, Target))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
pn, (Path Abs File
_, Target
t)) -> PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
t) [(PackageName, (Path Abs File, Target))]
localTargets
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets
[GhciPkgInfo]
pkgs <- InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (((Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> Maybe (Map PackageName [Path Abs File])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PackageName [Path Abs File], [Path Abs File])
-> Map PackageName [Path Abs File]
forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
[GhciPkgInfo] -> RIO env ()
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci
GhciOpts
opts
[(PackageName, (Path Abs File, Target))]
localTargets
Maybe (Path Abs File)
mainFile
[GhciPkgInfo]
pkgs
([Path Abs File]
-> ((Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File])
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Map PackageName [Path Abs File], [Path Abs File])
-> [Path Abs File]
forall a b. (a, b) -> b
snd Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets)
([PackageName]
nonLocalTargets [PackageName] -> [PackageName] -> [PackageName]
forall a. [a] -> [a] -> [a]
++ [PackageName]
addPkgs)
Map PackageName (Seq NamedComponent)
relevantDependencies
preprocessTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
rawTargets = do
let ([Text]
fileTargetsRaw, [Text]
normalTargetsRaw) =
(Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition
(\Text
t -> Text
".hs" Text -> Text -> Bool
`T.isSuffixOf` Text
t Bool -> Bool -> Bool
|| Text
".lhs" Text -> Text -> Bool
`T.isSuffixOf` Text
t)
[Text]
rawTargets
if Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
normalTargetsRaw
then do
[Path Abs File]
fileTargets <- [Text]
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fileTargetsRaw ((Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File])
-> (Text -> RIO env (Path Abs File)) -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ \Text
fp0 -> do
let fp :: String
fp = Text -> String
T.unpack Text
fp0
Maybe (Path Abs File)
mpath <- String -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
String -> m (Maybe (Path Abs File))
forgivingResolveFile' String
fp
case Maybe (Path Abs File)
mpath of
Maybe (Path Abs File)
Nothing -> GhciPrettyException -> RIO env (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (String -> GhciPrettyException
FileTargetIsInvalidAbsFile String
fp)
Just Path Abs File
path -> Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path Abs File] -> Either [Path Abs File] (Map PackageName Target)
forall a b. a -> Either a b
Left [Path Abs File]
fileTargets)
else do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { targetsCLI = normalTargetsRaw }
SMTargets
normalTargets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
RIO env SMTargets
-> (PrettyException -> RIO env SMTargets) -> RIO env SMTargets
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
case SomeException -> Maybe BuildPrettyException
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe BuildPrettyException)
-> SomeException -> Maybe BuildPrettyException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex of
Just (TargetParseException [StyleDoc]
xs) ->
GhciPrettyException -> RIO env SMTargets
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (GhciPrettyException -> RIO env SMTargets)
-> GhciPrettyException -> RIO env SMTargets
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
Maybe BuildPrettyException
_ -> PrettyException -> RIO env SMTargets
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PrettyException
pex
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ GhciPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM GhciPrettyException
Can'tSpecifyFilesAndTargets
Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
-> Either [Path Abs File] (Map PackageName Target)
forall a b. b -> Either a b
Right SMTargets
normalTargets.targets)
parseMainIsTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
mtarget = Maybe Text
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Text
mtarget ((Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target)))
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall a b. (a -> b) -> a -> b
$ \Text
target -> do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { targetsCLI = [target] }
SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
Map PackageName Target -> RIO env (Map PackageName Target)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTargets
targets.targets
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent =
Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (StyleDoc -> StyleDoc)
-> ((PackageName, NamedComponent) -> StyleDoc)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, NamedComponent) -> String)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> ((PackageName, NamedComponent) -> Text)
-> (PackageName, NamedComponent)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent
findFileTargets ::
HasEnvConfig env
=> [LocalPackage]
-> [Path Abs File]
-> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File])
findFileTargets :: forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
fileTargets = do
[(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages <- [LocalPackage]
-> (LocalPackage
-> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
-> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
locals ((LocalPackage
-> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
-> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])])
-> (LocalPackage
-> RIO env (LocalPackage, Map NamedComponent [Path Abs File]))
-> RIO env [(LocalPackage, Map NamedComponent [Path Abs File])]
forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp -> do
PackageComponentFile Map NamedComponent (Map ModuleName (Path Abs File))
_ Map NamedComponent [DotCabalPath]
compFiles Set (Path Abs File)
_ [PackageWarning]
_ <- Package -> Path Abs File -> RIO env PackageComponentFile
forall s (m :: * -> *).
(HasEnvConfig s, MonadReader s m, MonadThrow m, MonadUnliftIO m) =>
Package -> Path Abs File -> m PackageComponentFile
getPackageFile LocalPackage
lp.package LocalPackage
lp.cabalFP
(LocalPackage, Map NamedComponent [Path Abs File])
-> RIO env (LocalPackage, Map NamedComponent [Path Abs File])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage
lp, ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Path Abs File)
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> b) -> [a] -> [b]
map DotCabalPath -> Path Abs File
dotCabalGetPath) Map NamedComponent [DotCabalPath]
compFiles)
let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents =
(Path Abs File -> (Path Abs File, [(PackageName, NamedComponent)]))
-> [Path Abs File]
-> [(Path Abs File, [(PackageName, NamedComponent)])]
forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
fp -> (Path Abs File
fp, ) ([(PackageName, NamedComponent)]
-> (Path Abs File, [(PackageName, NamedComponent)]))
-> [(PackageName, NamedComponent)]
-> (Path Abs File, [(PackageName, NamedComponent)])
forall a b. (a -> b) -> a -> b
$ [(PackageName, NamedComponent)] -> [(PackageName, NamedComponent)]
forall a. Ord a => [a] -> [a]
L.sort ([(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)])
-> [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> a -> b
$
((LocalPackage, Map NamedComponent [Path Abs File])
-> [(PackageName, NamedComponent)])
-> [(LocalPackage, Map NamedComponent [Path Abs File])]
-> [(PackageName, NamedComponent)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(LocalPackage
lp, Map NamedComponent [Path Abs File]
files) -> ((NamedComponent, [Path Abs File])
-> (PackageName, NamedComponent))
-> [(NamedComponent, [Path Abs File])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((LocalPackage
lp.package.name,) (NamedComponent -> (PackageName, NamedComponent))
-> ((NamedComponent, [Path Abs File]) -> NamedComponent)
-> (NamedComponent, [Path Abs File])
-> (PackageName, NamedComponent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, [Path Abs File]) -> NamedComponent
forall a b. (a, b) -> a
fst)
(((NamedComponent, [Path Abs File]) -> Bool)
-> [(NamedComponent, [Path Abs File])]
-> [(NamedComponent, [Path Abs File])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path Abs File -> [Path Abs File] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Path Abs File
fp ([Path Abs File] -> Bool)
-> ((NamedComponent, [Path Abs File]) -> [Path Abs File])
-> (NamedComponent, [Path Abs File])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, [Path Abs File]) -> [Path Abs File]
forall a b. (a, b) -> b
snd) (Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent [Path Abs File]
files))
) [(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages
) [Path Abs File]
fileTargets
[Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results <- [(Path Abs File, [(PackageName, NamedComponent)])]
-> ((Path Abs File, [(PackageName, NamedComponent)])
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> RIO
env
[Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents (((Path Abs File, [(PackageName, NamedComponent)])
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> RIO
env
[Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))])
-> ((Path Abs File, [(PackageName, NamedComponent)])
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> RIO
env
[Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
forall a b. (a -> b) -> a -> b
$ \(Path Abs File
fp, [(PackageName, NamedComponent)]
xs) ->
case [(PackageName, NamedComponent)]
xs of
[] -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Couldn't find a component for file target"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, String -> StyleDoc
flow String
"This means that the correct GHC options might not be used. \
\Attempting to load the file anyway."
]
Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ Path Abs File
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. a -> Either a b
Left Path Abs File
fp
[(PackageName, NamedComponent)
x] -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Using configuration for"
, (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x
, String -> StyleDoc
flow String
"to load"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
]
Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, (PackageName, NamedComponent))
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
((PackageName, NamedComponent)
x:[(PackageName, NamedComponent)]
_) -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Multiple components contain file target"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent [(PackageName, NamedComponent)]
xs)
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Guessing the first one,"
, (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))))
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
-> RIO
env
(Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent)))
forall a b. (a -> b) -> a -> b
$ (Path Abs File, (PackageName, NamedComponent))
-> Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))
forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
let ([Path Abs File]
extraFiles, [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles) = [Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
-> ([Path Abs File],
[(Path Abs File, (PackageName, NamedComponent))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results
targetMap :: Map PackageName Target
targetMap =
(Map PackageName Target
-> Map PackageName Target -> Map PackageName Target)
-> Map PackageName Target
-> [Map PackageName Target]
-> Map PackageName Target
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PackageName Target
-> Map PackageName Target -> Map PackageName Target
forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
forall k a. Map k a
M.empty ([Map PackageName Target] -> Map PackageName Target)
-> [Map PackageName Target] -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$
((Path Abs File, (PackageName, NamedComponent))
-> Map PackageName Target)
-> [(Path Abs File, (PackageName, NamedComponent))]
-> [Map PackageName Target]
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
_, (PackageName
name, NamedComponent
comp)) -> PackageName -> Target -> Map PackageName Target
forall k a. k -> a -> Map k a
M.singleton PackageName
name (Set NamedComponent -> Target
TargetComps (NamedComponent -> Set NamedComponent
forall a. a -> Set a
S.singleton NamedComponent
comp)))
[(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
infoMap :: Map PackageName [Path Abs File]
infoMap =
(Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File])
-> Map PackageName [Path Abs File]
-> [Map PackageName [Path Abs File]]
-> Map PackageName [Path Abs File]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (([Path Abs File] -> [Path Abs File] -> [Path Abs File])
-> Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File]
-> Map PackageName [Path Abs File]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
(<>)) Map PackageName [Path Abs File]
forall k a. Map k a
M.empty ([Map PackageName [Path Abs File]]
-> Map PackageName [Path Abs File])
-> [Map PackageName [Path Abs File]]
-> Map PackageName [Path Abs File]
forall a b. (a -> b) -> a -> b
$
((Path Abs File, (PackageName, NamedComponent))
-> Map PackageName [Path Abs File])
-> [(Path Abs File, (PackageName, NamedComponent))]
-> [Map PackageName [Path Abs File]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
fp, (PackageName
name, NamedComponent
_)) -> PackageName -> [Path Abs File] -> Map PackageName [Path Abs File]
forall k a. k -> a -> Map k a
M.singleton PackageName
name [Path Abs File
fp])
[(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, Map PackageName [Path Abs File]
infoMap, [Path Abs File]
extraFiles)
getAllLocalTargets ::
HasEnvConfig env
=> GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets :: forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
ghciOpts Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
let targets :: Map PackageName Target
targets = Map PackageName Target
-> (Map PackageName Target -> Map PackageName Target)
-> Maybe (Map PackageName Target)
-> Map PackageName Target
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PackageName Target
targets0 (Map PackageName Target
-> Map PackageName Target -> Map PackageName Target
forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
targets0) Maybe (Map PackageName Target)
mainIsTargets
Map PackageName ProjectPackage
packages <- Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage))
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
-> Const
(Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
-> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> Getting
(Map PackageName ProjectPackage)
env
(Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> Map PackageName ProjectPackage)
-> SimpleGetter EnvConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap.project)
let directlyWanted :: [(PackageName, (Path Abs File, Target))]
directlyWanted = (((PackageName, ProjectPackage)
-> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, (Path Abs File, Target))])
-> [(PackageName, ProjectPackage)]
-> ((PackageName, ProjectPackage)
-> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PackageName, ProjectPackage)
-> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, ProjectPackage)]
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName ProjectPackage
packages) (((PackageName, ProjectPackage)
-> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))])
-> ((PackageName, ProjectPackage)
-> Maybe (PackageName, (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
\(PackageName
name, ProjectPackage
pp) ->
case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName Target
targets of
Just Target
simpleTargets -> (PackageName, (Path Abs File, Target))
-> Maybe (PackageName, (Path Abs File, Target))
forall a. a -> Maybe a
Just (PackageName
name, (ProjectPackage
pp.cabalFP, Target
simpleTargets))
Maybe Target
Nothing -> Maybe (PackageName, (Path Abs File, Target))
forall a. Maybe a
Nothing
let extraLoadDeps :: [(PackageName, (Path Abs File, Target))]
extraLoadDeps =
Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps GhciOpts
ghciOpts.loadLocalDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
directlyWanted
if [(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
then [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
else do
let extraList' :: [StyleDoc]
extraList' =
((PackageName, (Path Abs File, Target)) -> StyleDoc)
-> [(PackageName, (Path Abs File, Target))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc)
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps :: [StyleDoc]
extraList :: [StyleDoc]
extraList = Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
if GhciOpts
ghciOpts.loadLocalDeps
then StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
[ String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are local dependencies of your \
\targets, and you specified"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--load-local-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
]
[StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
else StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are intermediate dependencies of \
\your targets:"
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
)
[(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)
getAllNonLocalTargets ::
Map PackageName Target
-> RIO env [PackageName]
getAllNonLocalTargets :: forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
targets = do
let isNonLocal :: Target -> Bool
isNonLocal (TargetAll PackageType
PTDependency) = Bool
True
isNonLocal Target
_ = Bool
False
[PackageName] -> RIO env [PackageName]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageName] -> RIO env [PackageName])
-> [PackageName] -> RIO env [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> PackageName)
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Target) -> PackageName
forall a b. (a, b) -> a
fst ([(PackageName, Target)] -> [PackageName])
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> Bool)
-> [(PackageName, Target)] -> [(PackageName, Target)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
isNonLocal (Target -> Bool)
-> ((PackageName, Target) -> Target)
-> (PackageName, Target)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, Target) -> Target
forall a b. (a, b) -> b
snd) (Map PackageName Target -> [(PackageName, Target)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName Target
targets)
buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
ghciOpts [Text]
localTargets = do
let targets :: [Text]
targets = [Text]
localTargets [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack GhciOpts
ghciOpts.additionalPackages
Maybe (NonEmpty Text)
-> (NonEmpty Text -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Text]
targets) ((NonEmpty Text -> RIO env ()) -> RIO env ())
-> (NonEmpty Text -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Text
nonEmptyTargets ->
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless GhciOpts
ghciOpts.noBuild (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
case Either SomeException ()
eres of
Right () -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left SomeException
err -> do
case SomeException -> Maybe PrettyException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
Just (PrettyException e
prettyErr) -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
Maybe PrettyException
Nothing -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
forall a. IsString a => String -> a
fromString (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
"Build failed, but trying to launch GHCi anyway"
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages :: forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
pkgs = [String] -> (String -> m PackageName) -> m [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgs ((String -> m PackageName) -> m [PackageName])
-> (String -> m PackageName) -> m [PackageName]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
let mres :: Maybe PackageName
mres = (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier -> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
name)
Maybe PackageName -> Maybe PackageName -> Maybe PackageName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing String
name
m PackageName
-> (PackageName -> m PackageName)
-> Maybe PackageName
-> m PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GhciPrettyException -> m PackageName
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (GhciPrettyException -> m PackageName)
-> GhciPrettyException -> m PackageName
forall a b. (a -> b) -> a -> b
$ String -> GhciPrettyException
InvalidPackageOption String
name) PackageName -> m PackageName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageName
mres
runGhci ::
HasEnvConfig env
=> GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci
GhciOpts
ghciOpts
[(PackageName, (Path Abs File, Target))]
targets
Maybe (Path Abs File)
mainFile
[GhciPkgInfo]
pkgs
[Path Abs File]
extraFiles
[PackageName]
exposePackages
Map PackageName (Seq NamedComponent)
exposeInternalDep
= do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
let subDepsPackageUnhide :: PackageName -> t a -> [a]
subDepsPackageUnhide PackageName
pName t a
deps =
if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
deps then [] else [a
"-package", PackageName -> a
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pName]
pkgopts :: [String]
pkgopts = [String]
hidePkgOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
genOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
shouldHidePackages :: Bool
shouldHidePackages = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe
(Bool -> Bool
not ([GhciPkgInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages))
GhciOpts
ghciOpts.hidePackages
hidePkgOpts :: [String]
hidePkgOpts =
if Bool
shouldHidePackages
then
[String
"-hide-all-packages"]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if [(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else [])
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PackageName -> [String]) -> [PackageName] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
(\PackageName
n -> [String
"-package", PackageName -> String
packageNameString PackageName
n])
[PackageName]
exposePackages
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (PackageName -> Seq NamedComponent -> [String])
-> Map PackageName (Seq NamedComponent) -> [String]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
M.foldMapWithKey PackageName -> Seq NamedComponent -> [String]
forall {t :: * -> *} {a} {a}.
(Foldable t, IsString a) =>
PackageName -> t a -> [a]
subDepsPackageUnhide Map PackageName (Seq NamedComponent)
exposeInternalDep
else []
oneWordOpts :: r -> [a]
oneWordOpts r
bio
| Bool
shouldHidePackages = r
bio.oneWordOpts [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ r
bio.packageFlags
| Bool
otherwise = r
bio.oneWordOpts
genOpts :: [String]
genOpts = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd
((GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
forall {r} {a}.
(HasField "packageFlags" r [a], HasField "oneWordOpts" r [a]) =>
r -> [a]
oneWordOpts (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.opts)) [GhciPkgInfo]
pkgs)
([String]
omittedOpts, [String]
ghcOpts) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition String -> Bool
badForGhci ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$
(GhciPkgInfo -> [String]) -> [GhciPkgInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((NamedComponent, BuildInfoOpts) -> [String])
-> [(NamedComponent, BuildInfoOpts)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((.opts) (BuildInfoOpts -> [String])
-> ((NamedComponent, BuildInfoOpts) -> BuildInfoOpts)
-> (NamedComponent, BuildInfoOpts)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedComponent, BuildInfoOpts) -> BuildInfoOpts
forall a b. (a, b) -> b
snd) ([(NamedComponent, BuildInfoOpts)] -> [String])
-> (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)])
-> GhciPkgInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.opts)) [GhciPkgInfo]
pkgs
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
Text -> String
T.unpack
( Map ApplyGhcOptions [Text] -> [Text]
forall m. Monoid m => Map ApplyGhcOptions m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Config
config.ghcOptionsByCat
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (GhciPkgInfo -> [Text]) -> [GhciPkgInfo] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions (PackageName -> [Text])
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name)) [GhciPkgInfo]
pkgs
)
getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg =
[Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PackageName
pkg Config
config.ghcOptionsByName
badForGhci :: String -> Bool
badForGhci String
x =
String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"-O" String
x
Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"The following GHC options are incompatible with GHCi \
\and have not been passed to it:"
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
((String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
forall a. IsString a => String -> a
fromString ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts) :: [StyleDoc])
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
Path Abs Dir
oiDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
let odir :: [String]
odir =
[ String
"-odir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
, String
"-hidir=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
]
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
( String -> StyleDoc
flow String
"Configuring GHCi with the following packages:"
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
((GhciPkgInfo -> StyleDoc) -> [GhciPkgInfo] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc)
-> (GhciPkgInfo -> PackageName) -> GhciPkgInfo -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name)) [GhciPkgInfo]
pkgs :: [StyleDoc])
)
String
compilerExeName <-
Getting String env String -> RIO env String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting String env String -> RIO env String)
-> Getting String env String -> RIO env String
forall a b. (a -> b) -> a -> b
$ Getting String env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL Getting String env CompilerPaths
-> ((String -> Const String String)
-> CompilerPaths -> Const String CompilerPaths)
-> Getting String env String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.compiler) Getting String CompilerPaths (Path Abs File)
-> ((String -> Const String String)
-> Path Abs File -> Const String (Path Abs File))
-> (String -> Const String String)
-> CompilerPaths
-> Const String CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> String) -> SimpleGetter (Path Abs File) String
forall s a. (s -> a) -> SimpleGetter s a
to Path Abs File -> String
forall b t. Path b t -> String
toFilePath
let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
ProcessContext
menv <-
IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config
config.processContextSettings EnvSettings
defaultEnvSettings
RIO env b -> RIO env b
forall {a}. RIO env a -> RIO env a
withPackageWorkingDir (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ ProcessContext -> RIO env b -> RIO env b
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env b -> RIO env b) -> RIO env b -> RIO env b
forall a b. (a -> b) -> a -> b
$ String -> [String] -> RIO env b
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName GhciOpts
ghciOpts.ghcCommand)
( (String
"--interactive" : ) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
(if [GhciPkgInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then [String] -> [String]
forall a. a -> a
id else (String
"-i" : )) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
[String]
odir
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
extras
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> GhciOpts
ghciOpts.ghcOptions
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> GhciOpts
ghciOpts.args
)
withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
case [GhciPkgInfo]
pkgs of
[GhciPkgInfo
pkg] -> String -> RIO env a -> RIO env a
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath GhciPkgInfo
pkg.dir)
[GhciPkgInfo]
_ -> RIO env a -> RIO env a
forall a. a -> a
id
Path Abs Dir
tmpDirectory <- XdgDirectory -> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgCache (Maybe (Path Rel Dir) -> RIO env (Path Abs Dir))
-> Maybe (Path Rel Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
Path Rel Dir -> Maybe (Path Rel Dir)
forall a. a -> Maybe a
Just (Path Rel Dir
relDirStackProgName Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGhciScript)
Path Abs Dir
ghciDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
[String]
macrosOptions <- Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
if GhciOpts
ghciOpts.noLoadModules
then [String] -> RIO env ()
forall {b}. [String] -> RIO env b
execGhci [String]
macrosOptions
else do
[GhciPkgInfo] -> RIO env ()
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
[String]
scriptOptions <-
Path Abs Dir -> GhciScript -> RIO env [String]
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript
Path Abs Dir
tmpDirectory
([GhciPkgInfo]
-> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile GhciOpts
ghciOpts.onlyMain [Path Abs File]
extraFiles)
[String] -> RIO env ()
forall {b}. [String] -> RIO env b
execGhci ([String]
macrosOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
scriptOptions)
writeMacrosFile ::
HasTerm env
=> Path Abs Dir
-> [GhciPkgInfo]
-> RIO env [String]
writeMacrosFile :: forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
outputDirectory [GhciPkgInfo]
pkgs = do
[Path Abs File]
fps <- ([[Maybe (Path Abs File)]] -> [Path Abs File])
-> RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Path Abs File] -> [Path Abs File]
forall a. Ord a => [a] -> [a]
nubOrd ([Path Abs File] -> [Path Abs File])
-> ([[Maybe (Path Abs File)]] -> [Path Abs File])
-> [[Maybe (Path Abs File)]]
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe (Path Abs File)] -> [Path Abs File])
-> [[Maybe (Path Abs File)]] -> [Path Abs File]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Maybe (Path Abs File)] -> [Path Abs File]
forall a. [Maybe a] -> [a]
catMaybes) (RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File])
-> RIO env [[Maybe (Path Abs File)]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$
[GhciPkgInfo]
-> (GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
-> RIO env [[Maybe (Path Abs File)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgInfo]
pkgs ((GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
-> RIO env [[Maybe (Path Abs File)]])
-> (GhciPkgInfo -> RIO env [Maybe (Path Abs File)])
-> RIO env [[Maybe (Path Abs File)]]
forall a b. (a -> b) -> a -> b
$ \GhciPkgInfo
pkg -> [(NamedComponent, BuildInfoOpts)]
-> ((NamedComponent, BuildInfoOpts)
-> RIO env (Maybe (Path Abs File)))
-> RIO env [Maybe (Path Abs File)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM GhciPkgInfo
pkg.opts (((NamedComponent, BuildInfoOpts)
-> RIO env (Maybe (Path Abs File)))
-> RIO env [Maybe (Path Abs File)])
-> ((NamedComponent, BuildInfoOpts)
-> RIO env (Maybe (Path Abs File)))
-> RIO env [Maybe (Path Abs File)]
forall a b. (a -> b) -> a -> b
$ \(NamedComponent
_, BuildInfoOpts
bio) -> do
let cabalMacros :: Path Abs File
cabalMacros = BuildInfoOpts
bio.cabalMacros
Bool
exists <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
cabalMacros
if Bool
exists
then Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
cabalMacros
else do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL [StyleDoc
"Didn't find expected autogen file:", Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalMacros]
Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
[ByteString]
files <- IO [ByteString] -> RIO env [ByteString]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> RIO env [ByteString])
-> IO [ByteString] -> RIO env [ByteString]
forall a b. (a -> b) -> a -> b
$ (Path Abs File -> IO ByteString)
-> [Path Abs File] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> IO ByteString
S8.readFile (String -> IO ByteString)
-> (Path Abs File -> String) -> Path Abs File -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
fps
if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
files then [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else do
Path Abs File
out <- IO (Path Abs File) -> RIO env (Path Abs File)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File) -> RIO env (Path Abs File))
-> IO (Path Abs File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileCabalMacrosH (ByteString -> IO (Path Abs File))
-> ByteString -> IO (Path Abs File)
forall a b. (a -> b) -> a -> b
$
[ByteString] -> ByteString
S8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map
(ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n")
[ByteString]
files
[String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-optP-include", String
"-optP" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
out]
writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String]
writeGhciScript :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
outputDirectory GhciScript
script = do
Path Abs File
scriptPath <- IO (Path Abs File) -> m (Path Abs File)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File) -> m (Path Abs File))
-> IO (Path Abs File) -> m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileGhciScript (ByteString -> IO (Path Abs File))
-> ByteString -> IO (Path Abs File)
forall a b. (a -> b) -> a -> b
$
LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GhciScript -> LazyByteString
scriptToLazyByteString GhciScript
script
let scriptFilePath :: String
scriptFilePath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
scriptPath
String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
setScriptPerms String
scriptFilePath
[String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-ghci-script=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
scriptFilePath]
writeHashedFile ::
Path Abs Dir
-> Path Rel File
-> ByteString
-> IO (Path Abs File)
writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFile ByteString
contents = do
Path Rel Dir
relSha <- ByteString -> IO (Path Rel Dir)
forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes ByteString
contents
let outDir :: Path Abs Dir
outDir = Path Abs Dir
outputDirectory Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relSha
outFile :: Path Abs File
outFile = Path Abs Dir
outDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Bool
alreadyExists <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
outFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outDir
Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outFile (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
contents
Path Abs File -> IO (Path Abs File)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outFile
renderScript ::
[GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript :: [GhciPkgInfo]
-> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
let addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (Set (Either ModuleName (Path Abs File)) -> GhciScript)
-> Set (Either ModuleName (Path Abs File)) -> GhciScript
forall a b. (a -> b) -> a -> b
$ [Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((ModuleName -> Either ModuleName (Path Abs File))
-> [ModuleName] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either ModuleName (Path Abs File)
forall a b. a -> Either a b
Left [ModuleName]
allModules [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
forall a. [a] -> [a] -> [a]
++ [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
addMain :: [Either a (Path Abs File)]
addMain = [Either a (Path Abs File)]
-> (Path Abs File -> [Either a (Path Abs File)])
-> Maybe (Path Abs File)
-> [Either a (Path Abs File)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Either a (Path Abs File) -> [Either a (Path Abs File)]
forall a. a -> [a]
L.singleton (Either a (Path Abs File) -> [Either a (Path Abs File)])
-> (Path Abs File -> Either a (Path Abs File))
-> Path Abs File
-> [Either a (Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Either a (Path Abs File)
forall a b. b -> Either a b
Right) Maybe (Path Abs File)
mainFile
modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule (Set ModuleName -> GhciScript) -> Set ModuleName -> GhciScript
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
allModules :: [ModuleName]
allModules = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
nubOrd ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (GhciPkgInfo -> [ModuleName]) -> [GhciPkgInfo] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleMap -> [ModuleName]
forall k a. Map k a -> [k]
M.keys (ModuleMap -> [ModuleName])
-> (GhciPkgInfo -> ModuleMap) -> GhciPkgInfo -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.modules)) [GhciPkgInfo]
pkgs
case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
[] ->
if Bool
onlyMain
then
if Maybe (Path Abs File) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile
then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
else GhciScript
forall a. Monoid a => a
mempty
else GhciScript
addPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
[Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((Path Abs File -> Either ModuleName (Path Abs File))
-> [Path Abs File] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> Either ModuleName (Path Abs File)
forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets = (GhciPkgInfo -> [Path Abs File])
-> [GhciPkgInfo] -> [Path Abs File]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Path Abs File]] -> [Path Abs File])
-> (GhciPkgInfo -> [[Path Abs File]])
-> GhciPkgInfo
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Path Abs File] -> [[Path Abs File]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Path Abs File] -> [[Path Abs File]])
-> (GhciPkgInfo -> Maybe [Path Abs File])
-> GhciPkgInfo
-> [[Path Abs File]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.targetFiles))
figureOutMainFile ::
(HasRunner env, HasTerm env)
=> BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile :: forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
targets0 [GhciPkgInfo]
packages =
case [(PackageName, NamedComponent, Path Abs File)]
candidates of
[] -> Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
[c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Using"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, StyleDoc
"module:"
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate (PackageName, NamedComponent, Path Abs File)
c
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp)
(PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"The"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, String -> StyleDoc
flow String
"module to load is ambiguous. Candidates are:"
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line (((PackageName, NamedComponent, Path Abs File) -> StyleDoc)
-> [(PackageName, NamedComponent, Path Abs File)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates))
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You can specify which one to pick by:"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
[ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Specifying targets to"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack ghci")
, StyleDoc
"e.g."
, Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"stack ghci"
, (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {a} {c}.
(Semigroup a, IsString a) =>
(PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate
]
) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
, [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Specifying what the"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, String -> StyleDoc
flow String
"is e.g."
, Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"stack ghci"
, (PackageName, NamedComponent, Path Abs File) -> StyleDoc
forall {c}. (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate
]
) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
, String -> StyleDoc
flow
(String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String
"Choosing from the candidate above [1.."
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]."
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
IO (Maybe (Path Abs File)) -> RIO env (Maybe (Path Abs File))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
where
targets :: Map PackageName Target
targets = Map PackageName Target
-> Maybe (Map PackageName Target) -> Map PackageName Target
forall a. a -> Maybe a -> a
fromMaybe
([(PackageName, Target)] -> Map PackageName Target
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PackageName, Target)] -> Map PackageName Target)
-> [(PackageName, Target)] -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ ((PackageName, (Path Abs File, Target)) -> (PackageName, Target))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Target)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
k, (Path Abs File
_, Target
x)) -> (PackageName
k, Target
x)) [(PackageName, (Path Abs File, Target))]
targets0)
Maybe (Map PackageName Target)
mainIsTargets
candidates :: [(PackageName, NamedComponent, Path Abs File)]
candidates = do
GhciPkgInfo
pkg <- [GhciPkgInfo]
packages
case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GhciPkgInfo
pkg.name Map PackageName Target
targets of
Maybe Target
Nothing -> []
Just Target
target -> do
(NamedComponent
component,[Path Abs File]
mains) <-
Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])])
-> Map NamedComponent [Path Abs File]
-> [(NamedComponent, [Path Abs File])]
forall a b. (a -> b) -> a -> b
$
(NamedComponent -> [Path Abs File] -> Bool)
-> Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
wantedComponents)
GhciPkgInfo
pkg.mainIs
Path Abs File
main <- [Path Abs File]
mains
(PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GhciPkgInfo
pkg.name, NamedComponent
component, Path Abs File
main)
where
wantedComponents :: Set NamedComponent
wantedComponents =
BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target GhciPkgInfo
pkg.package
renderCandidate :: (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName, NamedComponent
namedComponent, Path Abs File
mainIs) =
let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex =
String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ([(PackageName, NamedComponent, Path Abs File)] -> String)
-> [(PackageName, NamedComponent, Path Abs File)]
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> ([(PackageName, NamedComponent, Path Abs File)] -> Maybe Int)
-> [(PackageName, NamedComponent, Path Abs File)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent, Path Abs File)
-> [(PackageName, NamedComponent, Path Abs File)] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
pkgNameText :: StyleDoc
pkgNameText = PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkgName
in Int -> StyleDoc -> StyleDoc
hang Int
4
(StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> StyleDoc -> StyleDoc
fill Int
4 ( [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
".")
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Package"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgNameText StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, StyleDoc
"component"
, Style -> StyleDoc -> StyleDoc
style
Style
PkgComponent
( StyleDoc
pkgNameText
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
namedComponent
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, StyleDoc
"with"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"main-is"
, StyleDoc
"file:"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
mainIs StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
candidateIndices :: [Int]
candidateIndices = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([(PackageName, NamedComponent, Path Abs File)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) [Int
1 :: Int ..]
userOption :: IO (Maybe (Path Abs File))
userOption = do
Text
option <- Text -> IO Text
forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
let selected :: Int
selected = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
(String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
selected [Int]
candidateIndices of
Maybe Int
Nothing -> do
String -> IO ()
putStrLn
String
"Not loading any main modules, as no valid module selected"
String -> IO ()
putStrLn String
""
Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
Just Int
op -> do
(PackageName
_, NamedComponent
_, Path Abs File
fp) <- IO (PackageName, NamedComponent, Path Abs File)
-> ((PackageName, NamedComponent, Path Abs File)
-> IO (PackageName, NamedComponent, Path Abs File))
-> Maybe (PackageName, NamedComponent, Path Abs File)
-> IO (PackageName, NamedComponent, Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(GhciPrettyException
-> IO (PackageName, NamedComponent, Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO GhciPrettyException
CandidatesIndexOutOfRangeBug)
(PackageName, NamedComponent, Path Abs File)
-> IO (PackageName, NamedComponent, Path Abs File)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
([(PackageName, NamedComponent, Path Abs File)]
candidates [(PackageName, NamedComponent, Path Abs File)]
-> Int -> Maybe (PackageName, NamedComponent, Path Abs File)
forall a. [a] -> Int -> Maybe a
!? Int
op)
String -> IO ()
putStrLn
(String
"Loading main module from candidate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
Int -> String
forall a. Show a => a -> String
show (Int
op Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", --main-is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp)
String -> IO ()
putStrLn String
""
Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File) -> IO (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp
sampleTargetArg :: (PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName
pkg, NamedComponent
comp, c
_) =
PackageName -> a
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkg
a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
":"
a -> a -> a
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> a
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
comp
sampleMainIsArg :: (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName
pkg, NamedComponent
comp, c
_) =
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"--main-is"
, PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pkg StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> NamedComponent -> StyleDoc
forall a. IsString a => NamedComponent -> a
renderComponentTo NamedComponent
comp
]
loadGhciPkgDescs ::
HasEnvConfig env
=> BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets =
[(PackageName, (Path Abs File, Target))]
-> ((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
-> RIO env [GhciPkgDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PackageName, (Path Abs File, Target))]
localTargets (((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
-> RIO env [GhciPkgDesc])
-> ((PackageName, (Path Abs File, Target)) -> RIO env GhciPkgDesc)
-> RIO env [GhciPkgDesc]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, (Path Abs File
cabalFP, Target
target)) ->
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalFP Target
target
loadGhciPkgDesc ::
HasEnvConfig env
=> BuildOptsCLI
-> PackageName
-> Path Abs File
-> Target
-> RIO env GhciPkgDesc
loadGhciPkgDesc :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalFP Target
target = do
EnvConfig
econfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
let sm :: SourceMap
sm = EnvConfig
econfig.sourceMap
sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
((.projectCommon.ghcOptions) (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project)
Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
((.depCommon.ghcOptions) (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.deps)
sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
( (.projectCommon.cabalConfigOpts) (ProjectPackage -> [Text]) -> Maybe ProjectPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project)
Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
((.depCommon.cabalConfigOpts) (DepPackage -> [Text]) -> Maybe DepPackage -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.deps)
sourceMapFlags :: Map FlagName Bool
sourceMapFlags =
Map FlagName Bool
-> (ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage
-> Map FlagName Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map FlagName Bool
forall a. Monoid a => a
mempty (.projectCommon.flags) (Maybe ProjectPackage -> Map FlagName Bool)
-> Maybe ProjectPackage -> Map FlagName Bool
forall a b. (a -> b) -> a -> b
$ PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name SourceMap
sm.project
config :: PackageConfig
config = PackageConfig
{ enableTests :: Bool
enableTests = Bool
True
, enableBenchmarks :: Bool
enableBenchmarks = Bool
True
, flags :: Map FlagName Bool
flags = Map FlagName Bool
getCliFlags Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall a. Semigroup a => a -> a -> a
<> Map FlagName Bool
sourceMapFlags
, ghcOptions :: [Text]
ghcOptions = [Text]
sourceMapGhcOptions
, cabalConfigOpts :: [Text]
cabalConfigOpts = [Text]
sourceMapCabalConfigOpts
, compilerVersion :: ActualCompiler
compilerVersion = ActualCompiler
compilerVersion
, platform :: Platform
platform = Getting Platform EnvConfig Platform -> EnvConfig -> Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform EnvConfig Platform
forall env. HasPlatform env => Lens' env Platform
Lens' EnvConfig Platform
platformL EnvConfig
econfig
}
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
_cabalFP) <-
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP)
GenericPackageDescription
gpkgdesc <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
Path Rel File
buildinfofp <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (PackageName -> String
packageNameString PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".buildinfo")
Bool
hasDotBuildinfo <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
let mbuildinfofp :: Maybe (Path Abs File)
mbuildinfofp
| Bool
hasDotBuildinfo = Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
| Bool
otherwise = Maybe (Path Abs File)
forall a. Maybe a
Nothing
Maybe HookedBuildInfo
mbuildinfo <- Maybe (Path Abs File)
-> (Path Abs File -> RIO env HookedBuildInfo)
-> RIO env (Maybe HookedBuildInfo)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Path Abs File)
mbuildinfofp Path Abs File -> RIO env HookedBuildInfo
forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m HookedBuildInfo
readDotBuildinfo
let pdp :: PackageDescription
pdp = PackageConfig -> GenericPackageDescription -> PackageDescription
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpkgdesc
package :: Package
package =
PackageConfig -> [PackageFlag] -> PackageDescription -> Package
packageFromPackageDescription PackageConfig
config (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpkgdesc) (PackageDescription -> Package) -> PackageDescription -> Package
forall a b. (a -> b) -> a -> b
$
PackageDescription
-> (HookedBuildInfo -> PackageDescription)
-> Maybe HookedBuildInfo
-> PackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PackageDescription
pdp (HookedBuildInfo -> PackageDescription -> PackageDescription
`C.updatePackageDescription` PackageDescription
pdp) Maybe HookedBuildInfo
mbuildinfo
GhciPkgDesc -> RIO env GhciPkgDesc
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgDesc
{ Package
package :: Package
package :: Package
package
, Path Abs File
cabalFP :: Path Abs File
cabalFP :: Path Abs File
cabalFP
, Target
target :: Target
target :: Target
target
}
where
cliFlags :: Map ApplyCLIFlag (Map FlagName Bool)
cliFlags = BuildOptsCLI
buildOptsCLI.flags
getCliFlags :: Map FlagName Bool
getCliFlags :: Map FlagName Bool
getCliFlags = [Map FlagName Bool] -> Map FlagName Bool
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ Map FlagName Bool
-> ApplyCLIFlag
-> Map ApplyCLIFlag (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall k a. Map k a
Map.empty (PackageName -> ApplyCLIFlag
ACFByName PackageName
name) Map ApplyCLIFlag (Map FlagName Bool)
cliFlags
, Map FlagName Bool
-> ApplyCLIFlag
-> Map ApplyCLIFlag (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall k a. Map k a
Map.empty ApplyCLIFlag
ACFAllProjectPackages Map ApplyCLIFlag (Map FlagName Bool)
cliFlags
]
getGhciPkgInfos ::
HasEnvConfig env
=> InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos :: forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets [GhciPkgDesc]
localTargets = do
(InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let localLibs :: [PackageName]
localLibs =
[ GhciPkgDesc
desc.package.name
| GhciPkgDesc
desc <- [GhciPkgDesc]
localTargets
, (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
isCLib GhciPkgDesc
desc.target
]
[GhciPkgDesc]
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgDesc]
localTargets ((GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo])
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall a b. (a -> b) -> a -> b
$ \GhciPkgDesc
pkgDesc ->
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
localLibs [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc
makeGhciPkgInfo ::
HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo :: forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc = do
BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
let pkg :: Package
pkg = GhciPkgDesc
pkgDesc.package
cabalFP :: Path Abs File
cabalFP = GhciPkgDesc
pkgDesc.cabalFP
target :: Target
target = GhciPkgDesc
pkgDesc.target
name :: PackageName
name = Package
pkg.name
(Map NamedComponent (Map ModuleName (Path Abs File))
mods, Map NamedComponent [DotCabalPath]
files, Map NamedComponent BuildInfoOpts
opts) <-
Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO
env
(Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath],
Map NamedComponent BuildInfoOpts)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m,
MonadUnliftIO m) =>
Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> m (Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath],
Map NamedComponent BuildInfoOpts)
getPackageOpts Package
pkg InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Path Abs File
cabalFP
let filteredOpts :: Map NamedComponent BuildInfoOpts
filteredOpts = Map NamedComponent BuildInfoOpts
-> Map NamedComponent BuildInfoOpts
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = (NamedComponent -> a -> Bool)
-> Map NamedComponent a -> Map NamedComponent a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
allWanted)
allWanted :: Set NamedComponent
allWanted = BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target Package
pkg
GhciPkgInfo -> RIO env GhciPkgInfo
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgInfo
{ PackageName
name :: PackageName
name :: PackageName
name
, opts :: [(NamedComponent, BuildInfoOpts)]
opts = Map NamedComponent BuildInfoOpts
-> [(NamedComponent, BuildInfoOpts)]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
, dir :: Path Abs Dir
dir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP
, modules :: ModuleMap
modules = [ModuleMap] -> ModuleMap
unionModuleMaps ([ModuleMap] -> ModuleMap) -> [ModuleMap] -> ModuleMap
forall a b. (a -> b) -> a -> b
$
((NamedComponent, Map ModuleName (Path Abs File)) -> ModuleMap)
-> [(NamedComponent, Map ModuleName (Path Abs File))]
-> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map
( \(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> (Path Abs File
-> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> Map ModuleName (Path Abs File) -> ModuleMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map
(\Path Abs File
fp -> Path Abs File
-> Set (PackageName, NamedComponent)
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp ((PackageName, NamedComponent) -> Set (PackageName, NamedComponent)
forall a. a -> Set a
S.singleton (Package
pkg.name, NamedComponent
comp)))
Map ModuleName (Path Abs File)
mp
)
(Map NamedComponent (Map ModuleName (Path Abs File))
-> [(NamedComponent, Map ModuleName (Path Abs File))]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent (Map ModuleName (Path Abs File))
-> Map NamedComponent (Map ModuleName (Path Abs File))
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
, mainIs :: Map NamedComponent [Path Abs File]
mainIs = ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
, cFiles :: [Path Abs File]
cFiles = [[Path Abs File]] -> [Path Abs File]
forall a. Monoid a => [a] -> a
mconcat
(Map NamedComponent [Path Abs File] -> [[Path Abs File]]
forall k a. Map k a -> [a]
M.elems (Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted (([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath) Map NamedComponent [DotCabalPath]
files)))
, targetFiles :: Maybe [Path Abs File]
targetFiles = Maybe (Map PackageName [Path Abs File])
mfileTargets Maybe (Map PackageName [Path Abs File])
-> (Map PackageName [Path Abs File] -> Maybe [Path Abs File])
-> Maybe [Path Abs File]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageName
-> Map PackageName [Path Abs File] -> Maybe [Path Abs File]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name
, package :: Package
package = Package
pkg
}
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 =
( if Package -> Bool
hasBuildableMainLibrary Package
pkg
then NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Ord a => a -> Set a -> Set a
S.insert NamedComponent
CLib ((StackUnqualCompName -> NamedComponent)
-> Set StackUnqualCompName -> Set NamedComponent
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic StackUnqualCompName -> NamedComponent
CSubLib Set StackUnqualCompName
buildableForeignLibs')
else Set NamedComponent
forall a. Set a
S.empty
)
Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Semigroup a => a -> a -> a
<> (StackUnqualCompName -> NamedComponent)
-> Set StackUnqualCompName -> Set NamedComponent
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic StackUnqualCompName -> NamedComponent
CExe Set StackUnqualCompName
buildableExes'
Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Semigroup a => a -> a -> a
<> (StackUnqualCompName -> NamedComponent)
-> Set StackUnqualCompName -> Set NamedComponent
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic StackUnqualCompName -> NamedComponent
CSubLib Set StackUnqualCompName
buildableSubLibs'
Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Semigroup a => a -> a -> a
<> ( if BuildOpts
bopts.tests
then (StackUnqualCompName -> NamedComponent)
-> Set StackUnqualCompName -> Set NamedComponent
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic StackUnqualCompName -> NamedComponent
CTest Set StackUnqualCompName
buildableTestSuites'
else Set NamedComponent
forall a. Set a
S.empty
)
Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Semigroup a => a -> a -> a
<> ( if BuildOpts
bopts.benchmarks
then (StackUnqualCompName -> NamedComponent)
-> Set StackUnqualCompName -> Set NamedComponent
forall a b. (a -> b) -> Set a -> Set b
S.mapMonotonic StackUnqualCompName -> NamedComponent
CBench Set StackUnqualCompName
buildableBenchmarks'
else Set NamedComponent
forall a. Set a
S.empty
)
where
buildableForeignLibs' :: Set StackUnqualCompName
buildableForeignLibs' = Package -> Set StackUnqualCompName
buildableForeignLibs Package
pkg
buildableSubLibs' :: Set StackUnqualCompName
buildableSubLibs' = Package -> Set StackUnqualCompName
buildableSubLibs Package
pkg
buildableExes' :: Set StackUnqualCompName
buildableExes' = Package -> Set StackUnqualCompName
buildableExes Package
pkg
buildableTestSuites' :: Set StackUnqualCompName
buildableTestSuites' = Package -> Set StackUnqualCompName
buildableTestSuites Package
pkg
buildableBenchmarks' :: Set StackUnqualCompName
buildableBenchmarks' = Package -> Set StackUnqualCompName
buildableBenchmarks Package
pkg
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = Set NamedComponent
forall a. Set a
S.empty
checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs =
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GhciPkgInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GhciPkgInfo]
pkgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StyleDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StyleDoc]
cabalFlagIssues) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"There are Cabal flags for this project which may prevent \
\GHCi from loading your code properly. In some cases it \
\can also load some projects which would otherwise fail to \
\build."
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat (StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine [StyleDoc]
cabalFlagIssues)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"To resolve, remove the flag(s) from the Cabal file(s) and \
\instead put them at the top of the Haskell files."
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"It isn't yet possible to load multiple packages into GHCi in \
\all cases. For further information, see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://ghc.haskell.org/trac/ghc/ticket/10827" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
where
cabalFlagIssues :: [StyleDoc]
cabalFlagIssues = ((String, [StyleDoc]) -> [StyleDoc])
-> [(String, [StyleDoc])] -> [StyleDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [StyleDoc]) -> [StyleDoc]
mixedFlag
[ ( String
"-XNoImplicitPrelude"
, [ String -> StyleDoc
flow String
"-XNoImplicitPrelude will be used, but GHCi will likely fail to \
\build things which depend on the implicit prelude."
]
)
, ( String
"-XCPP"
, [ String -> StyleDoc
flow String
"-XCPP will be used, but it can cause issues with multiline \
\strings. For further information, see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
)
, ( String
"-XNoTraditionalRecordSyntax"
, [ String -> StyleDoc
flow String
"-XNoTraditionalRecordSyntax will be used, but it break modules \
\which use record syntax."
]
)
, ( String
"-XTemplateHaskell"
, [ String -> StyleDoc
flow String
"-XTemplateHaskell will be used, but it may cause compilation \
\issues due to different parsing of '$' when there's no space \
\after it."
]
)
, ( String
"-XQuasiQuotes"
, [ String -> StyleDoc
flow String
"-XQuasiQuotes will be used, but it may cause parse failures \
\due to a different meaning for list comprehension syntax like \
\[x| ... ]"
]
)
, ( String
"-XSafe"
, [ String -> StyleDoc
flow String
"-XSafe will be used, but it will fail to compile unsafe \
\modules."
]
)
, ( String
"-XArrows"
, [ String -> StyleDoc
flow String
"-XArrows will be used, but it will cause non-arrow usages of \
\proc, (-<), (-<<) to fail"
]
)
, ( String
"-XOverloadedStrings"
, [ String -> StyleDoc
flow String
"-XOverloadedStrings will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( String
"-XOverloadedLists"
, [ String -> StyleDoc
flow String
"-XOverloadedLists will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( String
"-XMonoLocalBinds"
, [ String -> StyleDoc
flow String
"-XMonoLocalBinds will be used, but it can cause type errors in \
\code which expects generalized local bindings." ]
)
, ( String
"-XTypeFamilies"
, [ String -> StyleDoc
flow String
"-XTypeFamilies will be used, but it implies -XMonoLocalBinds, \
\and so can cause type errors in code which expects generalized \
\local bindings." ]
)
, ( String
"-XGADTs"
, [ String -> StyleDoc
flow String
"-XGADTs will be used, but it implies -XMonoLocalBinds, and so \
\can cause type errors in code which expects generalized local \
\bindings." ]
)
, ( String
"-XNewQualifiedOperators"
, [ String -> StyleDoc
flow String
"-XNewQualifiedOperators will be used, but this will break \
\usages of the old qualified operator syntax." ]
)
]
mixedFlag :: (String, [StyleDoc]) -> [StyleDoc]
mixedFlag (String
flag, [StyleDoc]
msgs) =
let x :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x = (String -> Bool)
-> ([(PackageName, NamedComponent)],
[(PackageName, NamedComponent)])
partitionComps (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
flag)
in [ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
msgs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++ ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x | ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> Bool
forall {a} {a}. (Eq a, Eq a) => ([a], [a]) -> Bool
mixedSettings ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x ]
mixedSettings :: ([a], [a]) -> Bool
mixedSettings ([a]
xs, [a]
ys) = [a]
xs [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [a]
ys [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
showWhich :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)]
haveIt, [(PackageName, NamedComponent)]
don'tHaveIt) =
[ String -> StyleDoc
flow String
"It is specified for:" ]
[StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
(((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, NamedComponent) -> String)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> ((PackageName, NamedComponent) -> Text)
-> (PackageName, NamedComponent)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
haveIt :: [StyleDoc])
[StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ String -> StyleDoc
flow String
"But not for:" ]
[StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
(((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> ((PackageName, NamedComponent) -> String)
-> (PackageName, NamedComponent)
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> ((PackageName, NamedComponent) -> Text)
-> (PackageName, NamedComponent)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
don'tHaveIt :: [StyleDoc])
partitionComps :: (String -> Bool)
-> ([(PackageName, NamedComponent)],
[(PackageName, NamedComponent)])
partitionComps String -> Bool
f = ((((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent))
-> [((PackageName, NamedComponent), [String])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent)
forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
xs, (((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent))
-> [((PackageName, NamedComponent), [String])]
-> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map ((PackageName, NamedComponent), [String])
-> (PackageName, NamedComponent)
forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
ys)
where
([((PackageName, NamedComponent), [String])]
xs, [((PackageName, NamedComponent), [String])]
ys) = (((PackageName, NamedComponent), [String]) -> Bool)
-> [((PackageName, NamedComponent), [String])]
-> ([((PackageName, NamedComponent), [String])],
[((PackageName, NamedComponent), [String])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
f ([String] -> Bool)
-> (((PackageName, NamedComponent), [String]) -> [String])
-> ((PackageName, NamedComponent), [String])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, NamedComponent), [String]) -> [String]
forall a b. (a, b) -> b
snd) [((PackageName, NamedComponent), [String])]
compsWithOpts
compsWithOpts :: [((PackageName, NamedComponent), [String])]
compsWithOpts = (((PackageName, NamedComponent), BuildInfoOpts)
-> ((PackageName, NamedComponent), [String]))
-> [((PackageName, NamedComponent), BuildInfoOpts)]
-> [((PackageName, NamedComponent), [String])]
forall a b. (a -> b) -> [a] -> [b]
map (\((PackageName, NamedComponent)
k, BuildInfoOpts
bio) ->
((PackageName, NamedComponent)
k, BuildInfoOpts
bio.oneWordOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfoOpts
bio.opts)) [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios
compsWithBios :: [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios =
[ ((GhciPkgInfo
pkg.name, NamedComponent
c), BuildInfoOpts
bio)
| GhciPkgInfo
pkg <- [GhciPkgInfo]
pkgs
, (NamedComponent
c, BuildInfoOpts
bio) <- GhciPkgInfo
pkg.opts
]
checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs =
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"Multiple files use the same module name:"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc)
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
where
duplicates ::
[(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates :: [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates =
((ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> Bool)
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ModuleName
_, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) -> Map (Path Abs File) (Set (PackageName, NamedComponent)) -> Int
forall k a. Map k a -> Int
M.size Map (Path Abs File) (Set (PackageName, NamedComponent))
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
ModuleMap
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall k a. Map k a -> [(k, a)]
M.toList (ModuleMap
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))])
-> ModuleMap
-> [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
forall a b. (a -> b) -> a -> b
$
[ModuleMap] -> ModuleMap
unionModuleMaps ((GhciPkgInfo -> ModuleMap) -> [GhciPkgInfo] -> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map (.modules) [GhciPkgInfo]
pkgs)
prettyDuplicate ::
(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate :: (ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate (ModuleName
mn, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) =
[StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Error (ModuleName -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn)
, String -> StyleDoc
flow String
"found at the following paths"
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc)
-> [(Path Abs File, Set (PackageName, NamedComponent))]
-> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Map (Path Abs File) (Set (PackageName, NamedComponent))
-> [(Path Abs File, Set (PackageName, NamedComponent))]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) (Set (PackageName, NamedComponent))
mp))
fileDuplicate ::
(Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Path Abs File
fp, Set (PackageName, NamedComponent)
comps) =
[StyleDoc] -> StyleDoc
fillSep
[ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
, StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (Set (PackageName, NamedComponent)
-> [(PackageName, NamedComponent)]
forall a. Set a -> [a]
S.toList Set (PackageName, NamedComponent)
comps))
]
targetWarnings ::
HasBuildConfig env
=> [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings :: forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets = do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
nonLocalTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Some targets"
, StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," ([StyleDoc] -> [StyleDoc]) -> [StyleDoc] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
(Style -> StyleDoc -> StyleDoc
style Style
Good (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName)
[PackageName]
nonLocalTargets
, String -> StyleDoc
flow String
"are not project packages, and so cannot be directly loaded. In \
\future versions of Stack, this might be supported - see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1441" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, String -> StyleDoc
flow String
"It can still be useful to specify these, as they will be passed \
\to ghci via"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"-package"
, StyleDoc
"flags."
]
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& Maybe (Map PackageName [Path Abs File], [Path Abs File]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
SMWanted
smWanted <- Getting SMWanted env SMWanted -> RIO env SMWanted
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SMWanted env SMWanted -> RIO env SMWanted)
-> Getting SMWanted env SMWanted -> RIO env SMWanted
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env)
-> ((SMWanted -> Const SMWanted SMWanted)
-> BuildConfig -> Const SMWanted BuildConfig)
-> Getting SMWanted env SMWanted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> SMWanted) -> SimpleGetter BuildConfig SMWanted
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted)
Either (Path Abs File) (Path Abs File)
configFile <- Getting
(Either (Path Abs File) (Path Abs File))
env
(Either (Path Abs File) (Path Abs File))
-> RIO env (Either (Path Abs File) (Path Abs File))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Either (Path Abs File) (Path Abs File))
env
(Either (Path Abs File) (Path Abs File))
forall env.
HasBuildConfig env =>
Lens' env (Either (Path Abs File) (Path Abs File))
Lens' env (Either (Path Abs File) (Path Abs File))
configFileL
case Either (Path Abs File) (Path Abs File)
configFile of
Left Path Abs File
_ -> ConfigPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM ConfigPrettyException
ConfigFileNotProjectLevelBug
Right Path Abs File
projectConfigFile -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
[ String -> StyleDoc
flow String
"No project package targets specified, so a plain ghci will be \
\started with no package hiding or package options."
, StyleDoc
""
, String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"You are using snapshot: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SMWanted
smWanted.snapshotLocation
, StyleDoc
""
, String -> StyleDoc
flow String
"If you want to use package hiding and options, then you can try \
\one of the following:"
, StyleDoc
""
, [StyleDoc] -> StyleDoc
bulletedList
[ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"If you want to start a different project configuration \
\than"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
projectConfigFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, String -> StyleDoc
flow String
"then you can use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack init"
, String -> StyleDoc
flow String
"to create a new"
, Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"stack.yaml"
, String -> StyleDoc
flow String
"for the packages in the current directory."
, StyleDoc
line
]
, String -> StyleDoc
flow String
"If you want to use the project configuration at"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
projectConfigFile StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, String -> StyleDoc
flow String
"then you can add to the value of its"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"packages"
, StyleDoc
"key."
]
, StyleDoc
""
]
getExtraLoadDeps ::
Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
Bool
loadAllDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
targets =
Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall k a. Map k a -> [(k, a)]
M.toList (Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))])
-> Map PackageName (Path Abs File, Target)
-> [(PackageName, (Path Abs File, Target))]
forall a b. (a -> b) -> a -> b
$
(\Map PackageName (Path Abs File, Target)
mp -> (Map PackageName (Path Abs File, Target)
-> PackageName -> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> [PackageName]
-> Map PackageName (Path Abs File, Target)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((PackageName
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> PackageName
-> Map PackageName (Path Abs File, Target)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map PackageName (Path Abs File, Target)
mp (((PackageName, (Path Abs File, Target)) -> PackageName)
-> [(PackageName, (Path Abs File, Target))] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst [(PackageName, (Path Abs File, Target))]
targets)) (Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
(Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe Maybe (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> a
id (Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Path Abs File, Target)
forall a b. (a -> b) -> a -> b
$
State (Map PackageName (Maybe (Path Abs File, Target))) ()
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall s a. State s a -> s -> s
execState (((PackageName, (Path Abs File, Target))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> [(PackageName, (Path Abs File, Target))]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PackageName
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go ([PackageName]
-> State (Map PackageName (Maybe (Path Abs File, Target))) ())
-> ((PackageName, (Path Abs File, Target)) -> [PackageName])
-> (PackageName, (Path Abs File, Target))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [PackageName]
getDeps (PackageName -> [PackageName])
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
targets)
([(PackageName, Maybe (Path Abs File, Target))]
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((PackageName, (Path Abs File, Target))
-> (PackageName, Maybe (Path Abs File, Target)))
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, Maybe (Path Abs File, Target))]
forall a b. (a -> b) -> [a] -> [b]
map (((Path Abs File, Target) -> Maybe (Path Abs File, Target))
-> (PackageName, (Path Abs File, Target))
-> (PackageName, Maybe (Path Abs File, Target))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just) [(PackageName, (Path Abs File, Target))]
targets))
where
getDeps :: PackageName -> [PackageName]
getDeps :: PackageName -> [PackageName]
getDeps PackageName
name =
case PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap of
Just LocalPackage
lp -> Package -> [PackageName]
listOfPackageDeps LocalPackage
lp.package
Maybe LocalPackage
_ -> []
go ::
PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go :: PackageName
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go PackageName
name = do
Map PackageName (Maybe (Path Abs File, Target))
cache <- StateT
(Map PackageName (Maybe (Path Abs File, Target)))
Identity
(Map PackageName (Maybe (Path Abs File, Target)))
forall s (m :: * -> *). MonadState s m => m s
get
case (PackageName
-> Map PackageName (Maybe (Path Abs File, Target))
-> Maybe (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Maybe (Path Abs File, Target))
cache, PackageName -> Map PackageName LocalPackage -> Maybe LocalPackage
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap) of
(Just (Just (Path Abs File, Target)
_), Maybe LocalPackage
_) -> Bool
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
(Just Maybe (Path Abs File, Target)
Nothing, Maybe LocalPackage
_) | Bool -> Bool
not Bool
loadAllDeps -> Bool
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(Maybe (Maybe (Path Abs File, Target))
_, Just LocalPackage
lp) -> do
let deps :: [PackageName]
deps = Package -> [PackageName]
listOfPackageDeps LocalPackage
lp.package
Bool
shouldLoad <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageName
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool)
-> [PackageName]
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PackageName
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
go [PackageName]
deps
if Bool
shouldLoad
then do
(Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name ((Path Abs File, Target) -> Maybe (Path Abs File, Target)
forall a. a -> Maybe a
Just (LocalPackage
lp.cabalFP, Set NamedComponent -> Target
TargetComps (NamedComponent -> Set NamedComponent
forall a. a -> Set a
S.singleton NamedComponent
CLib))))
Bool
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
(Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target)))
-> State (Map PackageName (Maybe (Path Abs File, Target))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (PackageName
-> Maybe (Path Abs File, Target)
-> Map PackageName (Maybe (Path Abs File, Target))
-> Map PackageName (Maybe (Path Abs File, Target))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name Maybe (Path Abs File, Target)
forall a. Maybe a
Nothing)
Bool
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> Bool
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity Bool
forall a.
a
-> StateT
(Map PackageName (Maybe (Path Abs File, Target))) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets :: forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets = (Target -> Target -> Target)
-> Map k Target -> Map k Target -> Map k Target
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith ((Target -> Target -> Target)
-> Map k Target -> Map k Target -> Map k Target)
-> (Target -> Target -> Target)
-> Map k Target
-> Map k Target
-> Map k Target
forall a b. (a -> b) -> a -> b
$ \Target
l Target
r -> case (Target
l, Target
r) of
(TargetAll PackageType
PTDependency, Target
_) -> Target
r
(TargetComps Set NamedComponent
sl, TargetComps Set NamedComponent
sr) -> Set NamedComponent -> Target
TargetComps (Set NamedComponent -> Set NamedComponent -> Set NamedComponent
forall a. Ord a => Set a -> Set a -> Set a
S.union Set NamedComponent
sl Set NamedComponent
sr)
(TargetComps Set NamedComponent
_, TargetAll PackageType
PTProject) -> PackageType -> Target
TargetAll PackageType
PTProject
(TargetComps Set NamedComponent
_, Target
_) -> Target
l
(TargetAll PackageType
PTProject, Target
_) -> PackageType -> Target
TargetAll PackageType
PTProject
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
p Target
t = case Target
t of
TargetComps Set NamedComponent
s -> (NamedComponent -> Bool) -> [NamedComponent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
p (Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
S.toList Set NamedComponent
s)
TargetAll PackageType
PTProject -> Bool
True
Target
_ -> Bool
False