{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Ghci
( GhciOpts (..)
, GhciPkgInfo (..)
, GhciException (..)
, GhciPrettyException (..)
, ghciCmd
, ghci
) where
import Control.Monad.State.Strict ( State, execState, get, modify )
import Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as L
import Data.List.Extra ( (!?) )
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import Path ((</>), parent, parseRelFile )
import Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
import Path.IO
( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir )
import RIO.NonEmpty ( nonEmpty )
import RIO.Process ( exec, withWorkingDir )
import Stack.Build ( buildLocalTargets )
import Stack.Build.Installed ( getInstalled, toInstallMap )
import Stack.Build.Source
( getLocalFlags, localDependencies, projectLocalPackages )
import Stack.Build.Target ( NeedTargets (..), parseTargets )
import Stack.Constants
( relDirGhciScript, relDirStackProgName, relFileCabalMacrosH
, relFileGhciScript, stackProgName'
)
import Stack.Constants.Config ( ghciDirL, objectInterfaceDirL )
import Stack.Ghci.Script
( GhciScript, ModuleName, cmdAdd, cmdModule
, scriptToLazyByteString
)
import Stack.Package
( buildableExes, buildableForeignLibs, getPackageOpts
, hasBuildableMainLibrary, listOfPackageDeps
, packageFromPackageDescription, readDotBuildinfo
, resolvePackageDescription, topSortPackageComponent
)
import Stack.PackageFile ( getPackageFile )
import Stack.Prelude
import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import Stack.Types.Build.Exception
( BuildPrettyException (..), pprintTargetParseErrors )
import Stack.Types.BuildConfig
( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) )
import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) )
import Stack.Types.BuildOptsCLI
( ApplyCLIFlag, BuildOptsCLI (..), defaultBuildOptsCLI )
import Stack.Types.CompCollection ( getBuildableListText )
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..) )
import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import Stack.Types.EnvConfig
( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
, shaPathForBytes
)
import Stack.Types.EnvSettings ( defaultEnvSettings )
import Stack.Types.Installed ( InstallMap, InstalledMap )
import Stack.Types.NamedComponent
( NamedComponent (..), isCLib, isCSubLib, renderComponentTo
, renderPkgComponent
)
import Stack.Types.Package
( BuildInfoOpts (..), LocalPackage (..), Package (..)
, PackageConfig (..), dotCabalCFilePath, dotCabalGetPath
, dotCabalMainPath
)
import Stack.Types.PackageFile ( PackageComponentFile (..) )
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Runner ( HasRunner, Runner )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), GlobalPackage
, PackageType (..), ProjectPackage (..), SMActual (..)
, SMTargets (..), SMWanted (..), SourceMap (..), Target (..)
)
import System.IO ( putStrLn )
import System.Permissions ( setScriptPerms )
data GhciException
= InvalidPackageOption !String
| LoadingDuplicateModules
| MissingFileTarget !String
| Can'tSpecifyFilesAndTargets
| Can'tSpecifyFilesAndMainIs
deriving (Int -> GhciException -> ShowS
[GhciException] -> ShowS
GhciException -> String
(Int -> GhciException -> ShowS)
-> (GhciException -> String)
-> ([GhciException] -> ShowS)
-> Show GhciException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciException -> ShowS
showsPrec :: Int -> GhciException -> ShowS
$cshow :: GhciException -> String
show :: GhciException -> String
$cshowList :: [GhciException] -> ShowS
showList :: [GhciException] -> ShowS
Show, Typeable)
instance Exception GhciException where
displayException :: GhciException -> String
displayException (InvalidPackageOption String
name) =
String
"Error: [S-6716]\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Failed to parse '--package' option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
displayException GhciException
LoadingDuplicateModules = [String] -> String
unlines
[ String
"Error: [S-9632]"
, String
"Not attempting to start ghci due to these duplicate modules."
, String
"Use '--no-load' to try to start it anyway, without loading any \
\modules (but these are still likely to cause errors)."
]
displayException (MissingFileTarget String
name) =
String
"Error: [S-3600]\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot find file target " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
displayException GhciException
Can'tSpecifyFilesAndTargets =
String
"Error: [S-9906]\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and package targets."
displayException GhciException
Can'tSpecifyFilesAndMainIs =
String
"Error: [S-5188]\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and '--main-is' \
\flag."
data GhciPrettyException
= GhciTargetParseException ![StyleDoc]
| CandidatesIndexOutOfRangeBug
deriving (Int -> GhciPrettyException -> ShowS
[GhciPrettyException] -> ShowS
GhciPrettyException -> String
(Int -> GhciPrettyException -> ShowS)
-> (GhciPrettyException -> String)
-> ([GhciPrettyException] -> ShowS)
-> Show GhciPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciPrettyException -> ShowS
showsPrec :: Int -> GhciPrettyException -> ShowS
$cshow :: GhciPrettyException -> String
show :: GhciPrettyException -> String
$cshowList :: [GhciPrettyException] -> ShowS
showList :: [GhciPrettyException] -> ShowS
Show, Typeable)
instance Pretty GhciPrettyException where
pretty :: GhciPrettyException -> StyleDoc
pretty (GhciTargetParseException [StyleDoc]
errs) =
StyleDoc
"[S-6948]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Note that to specify options to be passed to GHCi, use the"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--ghci-options"
, StyleDoc
"option."
]
pretty GhciPrettyException
CandidatesIndexOutOfRangeBug = String -> StyleDoc -> StyleDoc
bugPrettyReport String
"[S-1939]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"figureOutMainFile: index out of range."
instance Exception GhciPrettyException
data GhciOpts = GhciOpts
{ GhciOpts -> [Text]
targets :: ![Text]
, GhciOpts -> [String]
args :: ![String]
, GhciOpts -> [String]
ghcOptions :: ![String]
, GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
flags :: !(Map ApplyCLIFlag (Map FlagName Bool))
, GhciOpts -> Maybe String
ghcCommand :: !(Maybe FilePath)
, GhciOpts -> Bool
noLoadModules :: !Bool
, GhciOpts -> [String]
additionalPackages :: ![String]
, GhciOpts -> Maybe Text
mainIs :: !(Maybe Text)
, GhciOpts -> Bool
loadLocalDeps :: !Bool
, GhciOpts -> Bool
skipIntermediate :: !Bool
, GhciOpts -> Maybe Bool
hidePackages :: !(Maybe Bool)
, GhciOpts -> Bool
noBuild :: !Bool
, GhciOpts -> Bool
onlyMain :: !Bool
}
deriving Int -> GhciOpts -> ShowS
[GhciOpts] -> ShowS
GhciOpts -> String
(Int -> GhciOpts -> ShowS)
-> (GhciOpts -> String) -> ([GhciOpts] -> ShowS) -> Show GhciOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciOpts -> ShowS
showsPrec :: Int -> GhciOpts -> ShowS
$cshow :: GhciOpts -> String
show :: GhciOpts -> String
$cshowList :: [GhciOpts] -> ShowS
showList :: [GhciOpts] -> ShowS
Show
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.disableRun = True }
, benchmarkOpts =
bopts.benchmarkOpts { BenchmarkOpts.disableRun = True }
}
(EnvConfig -> EnvConfig) -> RIO EnvConfig () -> RIO EnvConfig ()
forall a.
(EnvConfig -> EnvConfig) -> RIO EnvConfig a -> RIO EnvConfig a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter EnvConfig EnvConfig BuildOpts BuildOpts
-> BuildOpts -> EnvConfig -> EnvConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter EnvConfig EnvConfig BuildOpts BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' EnvConfig BuildOpts
buildOptsL BuildOpts
boptsLocal) (GhciOpts -> RIO EnvConfig ()
forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
ghciOpts)
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
{ $sel:compiler:SMActual :: ActualCompiler
compiler = SourceMap
sourceMap.compiler
, $sel:project:SMActual :: Map PackageName ProjectPackage
project = SourceMap
sourceMap.project
, $sel:deps:SMActual :: Map PackageName DepPackage
deps = SourceMap
sourceMap.deps
, $sel:globals:SMActual :: Map PackageName GlobalPackage
globals = SourceMap
sourceMap.globalPkgs
}
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
case Maybe (Map PackageName Target)
mainIsTargets of
Maybe (Map PackageName Target)
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Map PackageName Target
_ -> GhciException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM GhciException
Can'tSpecifyFilesAndMainIs
(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 -> GhciException -> RIO env (Path Abs File)
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (String -> GhciException
MissingFileTarget String
fp)
Just Path Abs File
path -> Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path Abs File] -> Either [Path Abs File] (Map PackageName Target)
forall a b. a -> Either a b
Left [Path Abs File]
fileTargets)
else do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { targetsCLI = normalTargetsRaw }
SMTargets
normalTargets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
RIO env SMTargets
-> (PrettyException -> RIO env SMTargets) -> RIO env SMTargets
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
case SomeException -> Maybe BuildPrettyException
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe BuildPrettyException)
-> SomeException -> Maybe BuildPrettyException
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex of
Just (TargetParseException [StyleDoc]
xs) ->
GhciPrettyException -> RIO env SMTargets
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (GhciPrettyException -> RIO env SMTargets)
-> GhciPrettyException -> RIO env SMTargets
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
Maybe BuildPrettyException
_ -> PrettyException -> RIO env SMTargets
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PrettyException
pex
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ GhciException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
Either [Path Abs File] (Map PackageName Target)
-> RIO env (Either [Path Abs File] (Map PackageName Target))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
-> Either [Path Abs File] (Map PackageName Target)
forall a b. b -> Either a b
Right SMTargets
normalTargets.targets)
parseMainIsTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
mtarget = Maybe Text
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Text
mtarget ((Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target)))
-> (Text -> RIO env (Map PackageName Target))
-> RIO env (Maybe (Map PackageName Target))
forall a b. (a -> b) -> a -> b
$ \Text
target -> do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { targetsCLI = [target] }
SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
Map PackageName Target -> RIO env (Map PackageName Target)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTargets
targets.targets
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 (GhciOpts
ghciOpts.skipIntermediate Bool -> Bool -> Bool
&& Bool -> Bool
not GhciOpts
ghciOpts.loadLocalDeps)
Bool -> Bool -> Bool
|| [(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
then [(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
else do
let extraList' :: [StyleDoc]
extraList' =
((PackageName, (Path Abs File, Target)) -> StyleDoc)
-> [(PackageName, (Path Abs File, Target))] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc)
-> ((PackageName, (Path Abs File, Target)) -> PackageName)
-> (PackageName, (Path Abs File, Target))
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, (Path Abs File, Target)) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps :: [StyleDoc]
extraList :: [StyleDoc]
extraList = Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
if GhciOpts
ghciOpts.loadLocalDeps
then StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
[ String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are local dependencies of your \
\targets, and you specified"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--load-local-deps" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
]
[StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
else StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are intermediate dependencies of \
\your targets:"
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"(Use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--skip-intermediate-deps"
, String -> StyleDoc
flow String
"to omit these.)"
]
[(PackageName, (Path Abs File, Target))]
-> RIO env [(PackageName, (Path Abs File, Target))]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)
getAllNonLocalTargets ::
Map PackageName Target
-> RIO env [PackageName]
getAllNonLocalTargets :: forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
targets = do
let isNonLocal :: Target -> Bool
isNonLocal (TargetAll PackageType
PTDependency) = Bool
True
isNonLocal Target
_ = Bool
False
[PackageName] -> RIO env [PackageName]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageName] -> RIO env [PackageName])
-> [PackageName] -> RIO env [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> PackageName)
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Target) -> PackageName
forall a b. (a, b) -> a
fst ([(PackageName, Target)] -> [PackageName])
-> [(PackageName, Target)] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ ((PackageName, Target) -> Bool)
-> [(PackageName, Target)] -> [(PackageName, Target)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
isNonLocal (Target -> Bool)
-> ((PackageName, Target) -> Target)
-> (PackageName, Target)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, Target) -> Target
forall a b. (a, b) -> b
snd) (Map PackageName Target -> [(PackageName, Target)]
forall k a. Map k a -> [(k, a)]
M.toList Map PackageName Target
targets)
buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
ghciOpts [Text]
localTargets = do
let targets :: [Text]
targets = [Text]
localTargets [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack GhciOpts
ghciOpts.additionalPackages
case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Text]
targets of
Just NonEmpty Text
nonEmptyTargets | Bool -> Bool
not GhciOpts
ghciOpts.noBuild -> do
Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
case Either SomeException ()
eres of
Right () -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left SomeException
err -> do
case SomeException -> Maybe PrettyException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
Just (PrettyException e
prettyErr) -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ e -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
Maybe PrettyException
Nothing -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
forall a. IsString a => String -> a
fromString (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err)
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
"Build failed, but trying to launch GHCi anyway"
Maybe (NonEmpty Text)
_ ->
() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages :: forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
pkgs = [String] -> (String -> m PackageName) -> m [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgs ((String -> m PackageName) -> m [PackageName])
-> (String -> m PackageName) -> m [PackageName]
forall a b. (a -> b) -> a -> b
$ \String
name -> do
let mres :: Maybe PackageName
mres = (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier -> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
name)
Maybe PackageName -> Maybe PackageName -> Maybe PackageName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing String
name
m PackageName
-> (PackageName -> m PackageName)
-> Maybe PackageName
-> m PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GhciException -> m PackageName
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (GhciException -> m PackageName) -> GhciException -> m PackageName
forall a b. (a -> b) -> a -> b
$ String -> GhciException
InvalidPackageOption String
name) PackageName -> m PackageName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageName
mres
runGhci ::
HasEnvConfig env
=> GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> Map PackageName (Seq NamedComponent)
-> RIO env ()
runGhci
GhciOpts
ghciOpts
[(PackageName, (Path Abs File, Target))]
targets
Maybe (Path Abs File)
mainFile
[GhciPkgInfo]
pkgs
[Path Abs File]
extraFiles
[PackageName]
exposePackages
Map PackageName (Seq NamedComponent)
exposeInternalDep
= do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
let subDepsPackageUnhide :: PackageName -> t a -> [a]
subDepsPackageUnhide PackageName
pName t a
deps =
if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
deps then [] else [a
"-package", PackageName -> a
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pName]
pkgopts :: [String]
pkgopts = [String]
hidePkgOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
genOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
shouldHidePackages :: Bool
shouldHidePackages = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe
(Bool -> Bool
not ([GhciPkgInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages))
GhciOpts
ghciOpts.hidePackages
hidePkgOpts :: [String]
hidePkgOpts =
if Bool
shouldHidePackages
then
[String
"-hide-all-packages"]
[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
$
ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GhciScript -> ByteString
scriptToLazyByteString GhciScript
script
let scriptFilePath :: String
scriptFilePath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
scriptPath
String -> m ()
forall (m :: * -> *). Monad m => String -> m ()
setScriptPerms String
scriptFilePath
[String] -> m [String]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-ghci-script=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
scriptFilePath]
writeHashedFile ::
Path Abs Dir
-> Path Rel File
-> ByteString
-> IO (Path Abs File)
writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFile ByteString
contents = do
Path Rel Dir
relSha <- ByteString -> IO (Path Rel Dir)
forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes ByteString
contents
let outDir :: Path Abs Dir
outDir = Path Abs Dir
outputDirectory Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relSha
outFile :: Path Abs File
outFile = Path Abs Dir
outDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Bool
alreadyExists <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
outFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outDir
Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outFile (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
contents
Path Abs File -> IO (Path Abs File)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outFile
renderScript ::
[GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript :: [GhciPkgInfo]
-> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript
renderScript [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
let addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (Set (Either ModuleName (Path Abs File)) -> GhciScript)
-> Set (Either ModuleName (Path Abs File)) -> GhciScript
forall a b. (a -> b) -> a -> b
$ [Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((ModuleName -> Either ModuleName (Path Abs File))
-> [ModuleName] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Either ModuleName (Path Abs File)
forall a b. a -> Either a b
Left [ModuleName]
allModules [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
-> [Either ModuleName (Path Abs File)]
forall a. [a] -> [a] -> [a]
++ [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
addMain :: [Either a (Path Abs File)]
addMain = [Either a (Path Abs File)]
-> (Path Abs File -> [Either a (Path Abs File)])
-> Maybe (Path Abs File)
-> [Either a (Path Abs File)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Either a (Path Abs File) -> [Either a (Path Abs File)]
forall a. a -> [a]
L.singleton (Either a (Path Abs File) -> [Either a (Path Abs File)])
-> (Path Abs File -> Either a (Path Abs File))
-> Path Abs File
-> [Either a (Path Abs File)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Either a (Path Abs File)
forall a b. b -> Either a b
Right) Maybe (Path Abs File)
mainFile
modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule (Set ModuleName -> GhciScript) -> Set ModuleName -> GhciScript
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
allModules :: [ModuleName]
allModules = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
nubOrd ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (GhciPkgInfo -> [ModuleName]) -> [GhciPkgInfo] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleMap -> [ModuleName]
forall k a. Map k a -> [k]
M.keys (ModuleMap -> [ModuleName])
-> (GhciPkgInfo -> ModuleMap) -> GhciPkgInfo -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.modules)) [GhciPkgInfo]
pkgs
case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
[] ->
if Bool
onlyMain
then
if Maybe (Path Abs File) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile
then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList [Either ModuleName (Path Abs File)]
forall {a}. [Either a (Path Abs File)]
addMain)
else GhciScript
forall a. Monoid a => a
mempty
else GhciScript
addPhase GhciScript -> GhciScript -> GhciScript
forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
[Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd ([Either ModuleName (Path Abs File)]
-> Set (Either ModuleName (Path Abs File))
forall a. Ord a => [a] -> Set a
S.fromList ((Path Abs File -> Either ModuleName (Path Abs File))
-> [Path Abs File] -> [Either ModuleName (Path Abs File)]
forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> Either ModuleName (Path Abs File)
forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))
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
{ $sel:enableTests:PackageConfig :: Bool
enableTests = Bool
True
, $sel:enableBenchmarks:PackageConfig :: Bool
enableBenchmarks = Bool
True
, $sel:flags:PackageConfig :: Map FlagName Bool
flags =
BuildOptsCLI -> PackageName -> Map FlagName Bool
getLocalFlags BuildOptsCLI
buildOptsCLI PackageName
name Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map FlagName Bool
sourceMapFlags
, $sel:ghcOptions:PackageConfig :: [Text]
ghcOptions = [Text]
sourceMapGhcOptions
, $sel:cabalConfigOpts:PackageConfig :: [Text]
cabalConfigOpts = [Text]
sourceMapCabalConfigOpts
, $sel:compilerVersion:PackageConfig :: ActualCompiler
compilerVersion = ActualCompiler
compilerVersion
, $sel:platform:PackageConfig :: Platform
platform = Getting Platform EnvConfig Platform -> EnvConfig -> Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform EnvConfig Platform
forall env. HasPlatform env => Lens' env Platform
Lens' EnvConfig Platform
platformL EnvConfig
econfig
}
(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
$sel:package:GhciPkgDesc :: Package
package :: Package
package
, Path Abs File
$sel:cabalFP:GhciPkgDesc :: Path Abs File
cabalFP :: Path Abs File
cabalFP
, Target
$sel:target:GhciPkgDesc :: Target
target :: Target
target
}
getGhciPkgInfos ::
HasEnvConfig env
=> InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos :: forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets [GhciPkgDesc]
localTargets = do
(InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let localLibs :: [PackageName]
localLibs =
[ GhciPkgDesc
desc.package.name
| GhciPkgDesc
desc <- [GhciPkgDesc]
localTargets
, (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
isCLib GhciPkgDesc
desc.target
]
[GhciPkgDesc]
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgDesc]
localTargets ((GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo])
-> (GhciPkgDesc -> RIO env GhciPkgInfo) -> RIO env [GhciPkgInfo]
forall a b. (a -> b) -> a -> b
$ \GhciPkgDesc
pkgDesc ->
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
localLibs [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc
makeGhciPkgInfo ::
HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo :: forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc = do
BuildOpts
bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
let pkg :: Package
pkg = GhciPkgDesc
pkgDesc.package
cabalFP :: Path Abs File
cabalFP = GhciPkgDesc
pkgDesc.cabalFP
target :: Target
target = GhciPkgDesc
pkgDesc.target
name :: PackageName
name = Package
pkg.name
(Map NamedComponent (Map ModuleName (Path Abs File))
mods, Map NamedComponent [DotCabalPath]
files, Map NamedComponent BuildInfoOpts
opts) <-
Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO
env
(Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath],
Map NamedComponent BuildInfoOpts)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m,
MonadUnliftIO m) =>
Package
-> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> m (Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath],
Map NamedComponent BuildInfoOpts)
getPackageOpts Package
pkg InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Path Abs File
cabalFP
let filteredOpts :: Map NamedComponent BuildInfoOpts
filteredOpts = Map NamedComponent BuildInfoOpts
-> Map NamedComponent BuildInfoOpts
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = (NamedComponent -> a -> Bool)
-> Map NamedComponent a -> Map NamedComponent a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
allWanted)
allWanted :: Set NamedComponent
allWanted = BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target Package
pkg
GhciPkgInfo -> RIO env GhciPkgInfo
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgInfo
{ PackageName
$sel:name:GhciPkgInfo :: PackageName
name :: PackageName
name
, $sel:opts:GhciPkgInfo :: [(NamedComponent, BuildInfoOpts)]
opts = Map NamedComponent BuildInfoOpts
-> [(NamedComponent, BuildInfoOpts)]
forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
, $sel:dir:GhciPkgInfo :: Path Abs Dir
dir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP
, $sel:modules:GhciPkgInfo :: ModuleMap
modules = [ModuleMap] -> ModuleMap
unionModuleMaps ([ModuleMap] -> ModuleMap) -> [ModuleMap] -> ModuleMap
forall a b. (a -> b) -> a -> b
$
((NamedComponent, Map ModuleName (Path Abs File)) -> ModuleMap)
-> [(NamedComponent, Map ModuleName (Path Abs File))]
-> [ModuleMap]
forall a b. (a -> b) -> [a] -> [b]
map
( \(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> (Path Abs File
-> Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> Map ModuleName (Path Abs File) -> ModuleMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map
(\Path Abs File
fp -> Path Abs File
-> Set (PackageName, NamedComponent)
-> Map (Path Abs File) (Set (PackageName, NamedComponent))
forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp ((PackageName, NamedComponent) -> Set (PackageName, NamedComponent)
forall a. a -> Set a
S.singleton (Package
pkg.name, NamedComponent
comp)))
Map ModuleName (Path Abs File)
mp
)
(Map NamedComponent (Map ModuleName (Path Abs File))
-> [(NamedComponent, Map ModuleName (Path Abs File))]
forall k a. Map k a -> [(k, a)]
M.toList (Map NamedComponent (Map ModuleName (Path Abs File))
-> Map NamedComponent (Map ModuleName (Path Abs File))
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
, $sel:mainIs:GhciPkgInfo :: Map NamedComponent [Path Abs File]
mainIs = ([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
, $sel:cFiles:GhciPkgInfo :: [Path Abs File]
cFiles = [[Path Abs File]] -> [Path Abs File]
forall a. Monoid a => [a] -> a
mconcat
(Map NamedComponent [Path Abs File] -> [[Path Abs File]]
forall k a. Map k a -> [a]
M.elems (Map NamedComponent [Path Abs File]
-> Map NamedComponent [Path Abs File]
forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted (([DotCabalPath] -> [Path Abs File])
-> Map NamedComponent [DotCabalPath]
-> Map NamedComponent [Path Abs File]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((DotCabalPath -> Maybe (Path Abs File))
-> [DotCabalPath] -> [Path Abs File]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath) Map NamedComponent [DotCabalPath]
files)))
, $sel:targetFiles:GhciPkgInfo :: Maybe [Path Abs File]
targetFiles = Maybe (Map PackageName [Path Abs File])
mfileTargets Maybe (Map PackageName [Path Abs File])
-> (Map PackageName [Path Abs File] -> Maybe [Path Abs File])
-> Maybe [Path Abs File]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageName
-> Map PackageName [Path Abs File] -> Maybe [Path Abs File]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name
, $sel:package:GhciPkgInfo :: Package
package = Package
pkg
}
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
_ (TargetComps Set NamedComponent
cs) Package
_ = Set NamedComponent
cs
wantedPackageComponents BuildOpts
bopts (TargetAll PackageType
PTProject) Package
pkg = [NamedComponent] -> Set NamedComponent
forall a. Ord a => [a] -> Set a
S.fromList ([NamedComponent] -> Set NamedComponent)
-> [NamedComponent] -> Set NamedComponent
forall a b. (a -> b) -> a -> b
$
( if Package -> Bool
hasBuildableMainLibrary Package
pkg
then NamedComponent
CLib NamedComponent -> [NamedComponent] -> [NamedComponent]
forall a. a -> [a] -> [a]
: (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CSubLib [Text]
buildableForeignLibs'
else []
)
[NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe [Text]
buildableExes'
[NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CSubLib [Text]
buildableSubLibs
[NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (if BuildOpts
bopts.tests then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest [Text]
buildableTestSuites else [])
[NamedComponent] -> [NamedComponent] -> [NamedComponent]
forall a. Semigroup a => a -> a -> a
<> (if BuildOpts
bopts.benchmarks then (Text -> NamedComponent) -> [Text] -> [NamedComponent]
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench [Text]
buildableBenchmarks else [])
where
buildableForeignLibs' :: [Text]
buildableForeignLibs' = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
buildableForeignLibs Package
pkg
buildableSubLibs :: [Text]
buildableSubLibs = CompCollection StackLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.subLibraries
buildableExes' :: [Text]
buildableExes' = Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
buildableExes Package
pkg
buildableTestSuites :: [Text]
buildableTestSuites = CompCollection StackTestSuite -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.testSuites
buildableBenchmarks :: [Text]
buildableBenchmarks = CompCollection StackBenchmark -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
pkg.benchmarks
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = Set NamedComponent
forall a. Set a
S.empty
checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs =
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GhciPkgInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GhciPkgInfo]
pkgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
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 local packages, and so cannot be directly loaded. In \
\future versions of Stack, this might be supported - see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1441"
, StyleDoc
"."
, String -> StyleDoc
flow String
"It can still be useful to specify these, as they will be passed \
\to ghci via -package flags."
]
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(PackageName, (Path Abs File, Target))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& Maybe (Map PackageName [Path Abs File], [Path Abs File]) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
SMWanted
smWanted <- Getting SMWanted env SMWanted -> RIO env SMWanted
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SMWanted env SMWanted -> RIO env SMWanted)
-> Getting SMWanted env SMWanted -> RIO env SMWanted
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const SMWanted BuildConfig)
-> env -> Const SMWanted env)
-> ((SMWanted -> Const SMWanted SMWanted)
-> BuildConfig -> Const SMWanted BuildConfig)
-> Getting SMWanted env SMWanted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> SMWanted) -> SimpleGetter BuildConfig SMWanted
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted)
Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
Lens' env (Path Abs File)
stackYamlL
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
[ String -> StyleDoc
flow String
"No local targets specified, so a plain ghci will be started with \
\no package hiding or package options."
, StyleDoc
""
, String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"You are using snapshot: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SMWanted
smWanted.snapshotLocation
, StyleDoc
""
, String -> StyleDoc
flow String
"If you want to use package hiding and options, then you can try \
\one of the following:"
, StyleDoc
""
, [StyleDoc] -> StyleDoc
bulletedList
[ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"If you want to start a different project configuration \
\than"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, String -> StyleDoc
flow String
"then you can use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack init"
, String -> StyleDoc
flow String
"to create a new stack.yaml for the packages in the \
\current directory."
, StyleDoc
line
]
, String -> StyleDoc
flow String
"If you want to use the project configuration at"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, String -> StyleDoc
flow String
"then you can add to its 'packages' field."
]
, StyleDoc
""
]
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