{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Ghci
( GhciOpts (..)
, GhciPkgInfo (..)
, GhciException (..)
, GhciPrettyException (..)
, ghciCmd
, ghci
) where
import Control.Monad.State.Strict ( State, execState, get, modify )
import Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable ( foldl )
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Distribution.PackageDescription as C
import Path ((</>), parent, parseRelFile )
import Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
import Path.IO
( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir )
import RIO.Process
( HasProcessContext, exec, proc, readProcess_
, withWorkingDir
)
import Stack.Build ( buildLocalTargets )
import Stack.Build.Installed ( getInstalled, toInstallMap )
import Stack.Build.Source
( getLocalFlags, localDependencies, projectLocalPackages )
import Stack.Build.Target ( NeedTargets (..), parseTargets )
import Stack.Constants
( relDirGhciScript, relDirStackProgName, relFileCabalMacrosH
, relFileGhciScript, stackProgName'
)
import Stack.Constants.Config ( ghciDirL, objectInterfaceDirL )
import Stack.Ghci.Script
( GhciScript, ModuleName, cmdAdd, cmdCdGhc, cmdModule
, scriptToLazyByteString
)
import Stack.Package
( PackageDescriptionPair (..), packageFromPackageDescription
, readDotBuildinfo, resolvePackageDescription
)
import Stack.Prelude
import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import Stack.Types.Build.Exception
( BuildPrettyException (..), pprintTargetParseErrors )
import Stack.Types.BuildConfig
( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import Stack.Types.BuildOpts
( ApplyCLIFlag, BenchmarkOpts (..), BuildOpts (..)
, BuildOptsCLI (..), TestOpts (..), defaultBuildOptsCLI
)
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..) )
import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import Stack.Types.EnvConfig
( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
, shaPathForBytes
)
import Stack.Types.EnvSettings ( defaultEnvSettings )
import Stack.Types.NamedComponent
( NamedComponent (..), isCLib, renderPkgComponent )
import Stack.Types.Package
( BuildInfoOpts (..), InstallMap, InstalledMap
, LocalPackage (..), Package (..), PackageConfig (..)
, PackageLibraries (..), dotCabalCFilePath, dotCabalGetPath
, dotCabalMainPath, getPackageOpts
)
import Stack.Types.PackageFile ( getPackageFiles )
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Runner ( HasRunner, Runner )
import Stack.Types.SourceMap
( CommonPackage (..), DepPackage (..), GlobalPackage
, PackageType (..), ProjectPackage (..), SMActual (..)
, SMTargets (..), SMWanted (..), SourceMap (..), Target (..)
)
import System.IO ( putStrLn )
import System.Permissions ( setScriptPerms )
data GhciException
= InvalidPackageOption String
| LoadingDuplicateModules
| MissingFileTarget String
| Can'tSpecifyFilesAndTargets
| Can'tSpecifyFilesAndMainIs
deriving (Int -> GhciException -> ShowS
[GhciException] -> ShowS
GhciException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciException] -> ShowS
$cshowList :: [GhciException] -> ShowS
show :: GhciException -> String
$cshow :: GhciException -> String
showsPrec :: Int -> GhciException -> ShowS
$cshowsPrec :: Int -> GhciException -> ShowS
Show, Typeable)
instance Exception GhciException where
displayException :: GhciException -> String
displayException (InvalidPackageOption String
name) =
String
"Error: [S-6716]\n"
forall a. [a] -> [a] -> [a]
++ String
"Failed to parse '--package' option " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"."
displayException GhciException
LoadingDuplicateModules = [String] -> String
unlines
[ String
"Error: [S-9632]"
, String
"Not attempting to start ghci due to these duplicate modules."
, String
"Use '--no-load' to try to start it anyway, without loading any \
\modules (but these are still likely to cause errors)."
]
displayException (MissingFileTarget String
name) =
String
"Error: [S-3600]\n"
forall a. [a] -> [a] -> [a]
++ String
"Cannot find file target " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"."
displayException GhciException
Can'tSpecifyFilesAndTargets =
String
"Error: [S-9906]\n"
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and package targets."
displayException GhciException
Can'tSpecifyFilesAndMainIs =
String
"Error: [S-5188]\n"
forall a. [a] -> [a] -> [a]
++ String
"Cannot use 'stack ghci' with both file targets and '--main-is' \
\flag."
newtype GhciPrettyException
= GhciTargetParseException [StyleDoc]
deriving (Int -> GhciPrettyException -> ShowS
[GhciPrettyException] -> ShowS
GhciPrettyException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciPrettyException] -> ShowS
$cshowList :: [GhciPrettyException] -> ShowS
show :: GhciPrettyException -> String
$cshow :: GhciPrettyException -> String
showsPrec :: Int -> GhciPrettyException -> ShowS
$cshowsPrec :: Int -> GhciPrettyException -> ShowS
Show, Typeable)
instance Pretty GhciPrettyException where
pretty :: GhciPrettyException -> StyleDoc
pretty (GhciTargetParseException [StyleDoc]
errs) =
StyleDoc
"[S-6948]"
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
pprintTargetParseErrors [StyleDoc]
errs
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Note that to specify options to be passed to GHCi, use the"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--ghci-options"
, StyleDoc
"option."
]
instance Exception GhciPrettyException
data GhciOpts = GhciOpts
{ GhciOpts -> [Text]
ghciTargets :: ![Text]
, GhciOpts -> [String]
ghciArgs :: ![String]
, GhciOpts -> [String]
ghciGhcOptions :: ![String]
, GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
, GhciOpts -> Maybe String
ghciGhcCommand :: !(Maybe FilePath)
, GhciOpts -> Bool
ghciNoLoadModules :: !Bool
, GhciOpts -> [String]
ghciAdditionalPackages :: ![String]
, GhciOpts -> Maybe Text
ghciMainIs :: !(Maybe Text)
, GhciOpts -> Bool
ghciLoadLocalDeps :: !Bool
, GhciOpts -> Bool
ghciSkipIntermediate :: !Bool
, GhciOpts -> Maybe Bool
ghciHidePackages :: !(Maybe Bool)
, GhciOpts -> Bool
ghciNoBuild :: !Bool
, GhciOpts -> Bool
ghciOnlyMain :: !Bool
}
deriving Int -> GhciOpts -> ShowS
[GhciOpts] -> ShowS
GhciOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciOpts] -> ShowS
$cshowList :: [GhciOpts] -> ShowS
show :: GhciOpts -> String
$cshow :: GhciOpts -> String
showsPrec :: Int -> GhciOpts -> ShowS
$cshowsPrec :: Int -> GhciOpts -> ShowS
Show
data GhciPkgInfo = GhciPkgInfo
{ GhciPkgInfo -> PackageName
ghciPkgName :: !PackageName
, GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]
, GhciPkgInfo -> Path Abs Dir
ghciPkgDir :: !(Path Abs Dir)
, GhciPkgInfo -> ModuleMap
ghciPkgModules :: !ModuleMap
, GhciPkgInfo -> [Path Abs File]
ghciPkgCFiles :: ![Path Abs File]
, GhciPkgInfo -> Map NamedComponent [Path Abs File]
ghciPkgMainIs :: !(Map NamedComponent [Path Abs File])
, GhciPkgInfo -> Maybe [Path Abs File]
ghciPkgTargetFiles :: !(Maybe [Path Abs File])
, GhciPkgInfo -> Package
ghciPkgPackage :: !Package
}
deriving Int -> GhciPkgInfo -> ShowS
[GhciPkgInfo] -> ShowS
GhciPkgInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciPkgInfo] -> ShowS
$cshowList :: [GhciPkgInfo] -> ShowS
show :: GhciPkgInfo -> String
$cshow :: GhciPkgInfo -> String
showsPrec :: Int -> GhciPkgInfo -> ShowS
$cshowsPrec :: Int -> GhciPkgInfo -> ShowS
Show
data GhciPkgDesc = GhciPkgDesc
{ GhciPkgDesc -> Package
ghciDescPkg :: !Package
, GhciPkgDesc -> Path Abs File
ghciDescCabalFp :: !(Path Abs File)
, GhciPkgDesc -> Target
ghciDescTarget :: !Target
}
type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent)))
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Ord a => Set a -> Set a -> Set a
S.union)
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd GhciOpts
ghciOpts =
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ boptsCLITargets :: [Text]
boptsCLITargets = forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (GhciOpts -> [String]
ghciAdditionalPackages GhciOpts
ghciOpts)
, boptsCLIInitialBuildSteps :: Bool
boptsCLIInitialBuildSteps = Bool
True
, boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags GhciOpts
ghciOpts
, boptsCLIGhcOptions :: [Text]
boptsCLIGhcOptions = forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack (GhciOpts -> [String]
ghciGhcOptions GhciOpts
ghciOpts)
}
in forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI forall a b. (a -> b) -> a -> b
$ do
BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
let boptsLocal :: BuildOpts
boptsLocal = BuildOpts
bopts
{ boptsTestOpts :: TestOpts
boptsTestOpts = (BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts) { toDisableRun :: Bool
toDisableRun = Bool
True }
, boptsBenchmarkOpts :: BenchmarkOpts
boptsBenchmarkOpts =
(BuildOpts -> BenchmarkOpts
boptsBenchmarkOpts BuildOpts
bopts) { beoDisableRun :: Bool
beoDisableRun = Bool
True }
}
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> b -> s -> t
set forall s. HasConfig s => Lens' s BuildOpts
buildOptsL BuildOpts
boptsLocal) (forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci GhciOpts
ghciOpts)
ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci :: forall env. HasEnvConfig env => GhciOpts -> RIO env ()
ghci opts :: GhciOpts
opts@GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} = do
let buildOptsCLI :: BuildOptsCLI
buildOptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ boptsCLITargets :: [Text]
boptsCLITargets = []
, boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = Map ApplyCLIFlag (Map FlagName Bool)
ghciFlags
}
SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
[LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
[LocalPackage]
depLocals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
let localMap :: Map PackageName LocalPackage
localMap =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Package -> PackageName
packageName forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp, LocalPackage
lp) | LocalPackage
lp <- [LocalPackage]
locals forall a. [a] -> [a] -> [a]
++ [LocalPackage]
depLocals]
sma :: SMActual GlobalPackage
sma = SMActual
{ smaCompiler :: ActualCompiler
smaCompiler = SourceMap -> ActualCompiler
smCompiler SourceMap
sourceMap
, smaProject :: Map PackageName ProjectPackage
smaProject = SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap
, smaDeps :: Map PackageName DepPackage
smaDeps = SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap
, smaGlobal :: Map PackageName GlobalPackage
smaGlobal = SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap
}
Maybe (Map PackageName Target)
mainIsTargets <- forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
ghciMainIs
Either [Path Abs File] (Map PackageName Target)
etargets <- forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
ghciTargets
(Map PackageName Target
inputTargets, Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) <- case Either [Path Abs File] (Map PackageName Target)
etargets of
Right Map PackageName Target
packageTargets -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
packageTargets, forall a. Maybe a
Nothing)
Left [Path Abs File]
rawFileTargets -> do
case Maybe (Map PackageName Target)
mainIsTargets of
Maybe (Map PackageName Target)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Map PackageName Target
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndMainIs
(Map PackageName Target
targetMap, Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles) <- forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
rawFileTargets
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, forall a. a -> Maybe a
Just (Map PackageName [Path Abs File]
fileInfo, [Path Abs File]
extraFiles))
[(PackageName, (Path Abs File, Target))]
localTargets <- forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts
opts Map PackageName Target
inputTargets Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap
[PackageName]
nonLocalTargets <- forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
inputTargets
[PackageName]
addPkgs <- forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
ghciAdditionalPackages
[GhciPkgDesc]
pkgDescs <- forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets
BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
Maybe (Path Abs File)
mainFile <- if Bool
ghciNoLoadModules
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else do
[GhciPkgInfo]
pkgs0 <- forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
localTargets [GhciPkgInfo]
pkgs0
let pkgTargets :: PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
targets =
case Target
targets of
TargetAll PackageType
_ -> [String -> Text
T.pack (PackageName -> String
packageNameString PackageName
pn)]
TargetComps Set NamedComponent
comps -> [(PackageName, NamedComponent) -> Text
renderPkgComponent (PackageName
pn, NamedComponent
c) | NamedComponent
c <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps]
forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts
opts forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
pn, (Path Abs File
_, Target
t)) -> PackageName -> Target -> [Text]
pkgTargets PackageName
pn Target
t) [(PackageName, (Path Abs File, Target))]
localTargets
forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets
[GhciPkgInfo]
pkgs <- forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) [GhciPkgDesc]
pkgDescs
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs
forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci
GhciOpts
opts
[(PackageName, (Path Abs File, Target))]
localTargets
Maybe (Path Abs File)
mainFile
[GhciPkgInfo]
pkgs
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a b. (a, b) -> b
snd Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets)
([PackageName]
nonLocalTargets forall a. [a] -> [a] -> [a]
++ [PackageName]
addPkgs)
preprocessTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma [Text]
rawTargets = do
let ([Text]
fileTargetsRaw, [Text]
normalTargetsRaw) =
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition
(\Text
t -> Text
".hs" Text -> Text -> Bool
`T.isSuffixOf` Text
t Bool -> Bool -> Bool
|| Text
".lhs" Text -> Text -> Bool
`T.isSuffixOf` Text
t)
[Text]
rawTargets
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
normalTargetsRaw
then do
[Path Abs File]
fileTargets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fileTargetsRaw forall a b. (a -> b) -> a -> b
$ \Text
fp0 -> do
let fp :: String
fp = Text -> String
T.unpack Text
fp0
Maybe (Path Abs File)
mpath <- forall (m :: * -> *).
MonadIO m =>
String -> m (Maybe (Path Abs File))
forgivingResolveFile' String
fp
case Maybe (Path Abs File)
mpath of
Maybe (Path Abs File)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> GhciException
MissingFileTarget String
fp)
Just Path Abs File
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
path
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left [Path Abs File]
fileTargets)
else do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text]
normalTargetsRaw }
SMTargets
normalTargets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \pex :: PrettyException
pex@(PrettyException e
ex) ->
case forall e. Exception e => SomeException -> Maybe e
fromException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException e
ex of
Just (TargetParseException [StyleDoc]
xs) ->
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> GhciPrettyException
GhciTargetParseException [StyleDoc]
xs
Maybe BuildPrettyException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
pex
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
fileTargetsRaw) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GhciException
Can'tSpecifyFilesAndTargets
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SMTargets -> Map PackageName Target
smtTargets SMTargets
normalTargets)
parseMainIsTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets BuildOptsCLI
buildOptsCLI SMActual GlobalPackage
sma Maybe Text
mtarget = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Text
mtarget forall a b. (a -> b) -> a -> b
$ \Text
target -> do
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
buildOptsCLI { boptsCLITargets :: [Text]
boptsCLITargets = [Text
target] }
SMTargets
targets <- forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
AllowNoTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
sma
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SMTargets -> Map PackageName Target
smtTargets SMTargets
targets
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent =
Style -> StyleDoc -> StyleDoc
style Style
PkgComponent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent
findFileTargets ::
HasEnvConfig env
=> [LocalPackage]
-> [Path Abs File]
-> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File])
findFileTargets :: forall env.
HasEnvConfig env =>
[LocalPackage]
-> [Path Abs File]
-> RIO
env
(Map PackageName Target, Map PackageName [Path Abs File],
[Path Abs File])
findFileTargets [LocalPackage]
locals [Path Abs File]
fileTargets = do
[(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
locals forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp -> do
(Map NamedComponent (Map ModuleName (Path Abs File))
_,Map NamedComponent [DotCabalPath]
compFiles,Set (Path Abs File)
_,[PackageWarning]
_) <- GetPackageFiles
-> forall env.
HasEnvConfig env =>
Path Abs File
-> RIO
env
(Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath], Set (Path Abs File),
[PackageWarning])
getPackageFiles (Package -> GetPackageFiles
packageFiles (LocalPackage -> Package
lpPackage LocalPackage
lp)) (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage
lp, forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> b) -> [a] -> [b]
map DotCabalPath -> Path Abs File
dotCabalGetPath) Map NamedComponent [DotCabalPath]
compFiles)
let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents =
forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
fp -> (Path Abs File
fp, ) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(LocalPackage
lp, Map NamedComponent [Path Abs File]
files) -> forall a b. (a -> b) -> [a] -> [b]
map ((Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp), ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
(forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Path Abs File
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent [Path Abs File]
files))
) [(LocalPackage, Map NamedComponent [Path Abs File])]
filePackages
) [Path Abs File]
fileTargets
[Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents forall a b. (a -> b) -> a -> b
$ \(Path Abs File
fp, [(PackageName, NamedComponent)]
xs) ->
case [(PackageName, NamedComponent)]
xs of
[] -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Couldn't find a component for file target"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, String -> StyleDoc
flow String
"This means that the correct GHC options might not be used. \
\Attempting to load the file anyway."
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Path Abs File
fp
[(PackageName, NamedComponent)
x] -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Using configuration for"
, (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x
, String -> StyleDoc
flow String
"to load"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
((PackageName, NamedComponent)
x:[(PackageName, NamedComponent)]
_) -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Multiple components contain file target"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent [(PackageName, NamedComponent)]
xs)
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Guessing the first one,"
, (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (PackageName, NamedComponent)
x forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Path Abs File
fp, (PackageName, NamedComponent)
x)
let ([Path Abs File]
extraFiles, [(Path Abs File, (PackageName, NamedComponent))]
associatedFiles) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
(Path Abs File) (Path Abs File, (PackageName, NamedComponent))]
results
targetMap :: Map PackageName Target
targetMap =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
_, (PackageName
name, NamedComponent
comp)) -> forall k a. k -> a -> Map k a
M.singleton PackageName
name (Set NamedComponent -> Target
TargetComps (forall a. a -> Set a
S.singleton NamedComponent
comp)))
[(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
infoMap :: Map PackageName [Path Abs File]
infoMap =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)) forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(Path Abs File
fp, (PackageName
name, NamedComponent
_)) -> forall k a. k -> a -> Map k a
M.singleton PackageName
name [Path Abs File
fp])
[(Path Abs File, (PackageName, NamedComponent))]
associatedFiles
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName Target
targetMap, Map PackageName [Path Abs File]
infoMap, [Path Abs File]
extraFiles)
getAllLocalTargets ::
HasEnvConfig env
=> GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets :: forall env.
HasEnvConfig env =>
GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} Map PackageName Target
targets0 Maybe (Map PackageName Target)
mainIsTargets Map PackageName LocalPackage
localMap = do
let targets :: Map PackageName Target
targets = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map PackageName Target
targets0 (forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets Map PackageName Target
targets0) Maybe (Map PackageName Target)
mainIsTargets
Map PackageName ProjectPackage
packages <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> Map PackageName ProjectPackage
smProject
let directlyWanted :: [(PackageName, (Path Abs File, Target))]
directlyWanted = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName ProjectPackage
packages) forall a b. (a -> b) -> a -> b
$
\(PackageName
name, ProjectPackage
pp) ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName Target
targets of
Just Target
simpleTargets -> forall a. a -> Maybe a
Just (PackageName
name, (ProjectPackage -> Path Abs File
ppCabalFP ProjectPackage
pp, Target
simpleTargets))
Maybe Target
Nothing -> forall a. Maybe a
Nothing
let extraLoadDeps :: [(PackageName, (Path Abs File, Target))]
extraLoadDeps = Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps Bool
ghciLoadLocalDeps Map PackageName LocalPackage
localMap [(PackageName, (Path Abs File, Target))]
directlyWanted
if (Bool
ghciSkipIntermediate Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ghciLoadLocalDeps) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
extraLoadDeps
then forall (f :: * -> *) a. Applicative f => a -> f a
pure [(PackageName, (Path Abs File, Target))]
directlyWanted
else do
let extraList' :: [StyleDoc]
extraList' =
forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
extraLoadDeps :: [StyleDoc]
extraList :: [StyleDoc]
extraList = forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False [StyleDoc]
extraList'
if Bool
ghciLoadLocalDeps
then forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$
[ String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are local dependencies of your \
\targets, and you specified"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--load-local-deps" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
]
forall a. Semigroup a => a -> a -> a
<> [StyleDoc]
extraList
else forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"The following libraries will also be loaded into \
\GHCi because they are intermediate dependencies of \
\your targets:"
forall a. a -> [a] -> [a]
: [StyleDoc]
extraList
)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"(Use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--skip-intermediate-deps"
, String -> StyleDoc
flow String
"to omit these.)"
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, (Path Abs File, Target))]
directlyWanted forall a. [a] -> [a] -> [a]
++ [(PackageName, (Path Abs File, Target))]
extraLoadDeps)
getAllNonLocalTargets ::
Map PackageName Target
-> RIO env [PackageName]
getAllNonLocalTargets :: forall env. Map PackageName Target -> RIO env [PackageName]
getAllNonLocalTargets Map PackageName Target
targets = do
let isNonLocal :: Target -> Bool
isNonLocal (TargetAll PackageType
PTDependency) = Bool
True
isNonLocal Target
_ = Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Target -> Bool
isNonLocal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
M.toList Map PackageName Target
targets)
buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps :: forall env. HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [Text]
localTargets = do
let targets :: [Text]
targets = [Text]
localTargets forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
ghciAdditionalPackages
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
targets of
Just NonEmpty Text
nonEmptyTargets | Bool -> Bool
not Bool
ghciNoBuild -> do
Either SomeException ()
eres <- forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyTargets
case Either SomeException ()
eres of
Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left SomeException
err -> do
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
Just (PrettyException e
prettyErr) -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> StyleDoc
pretty e
prettyErr
Maybe PrettyException
Nothing -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (forall e. Exception e => e -> String
displayException SomeException
err)
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn StyleDoc
"Build failed, but trying to launch GHCi anyway"
Maybe (NonEmpty Text)
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages :: forall (m :: * -> *). MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages [String]
pkgs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgs forall a b. (a -> b) -> a -> b
$ \String
name -> do
let mres :: Maybe PackageName
mres = (PackageIdentifier -> PackageName
pkgName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
name)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing String
name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> GhciException
InvalidPackageOption String
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageName
mres
runGhci ::
HasEnvConfig env
=> GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci :: forall env.
HasEnvConfig env =>
GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci GhciOpts{Bool
[String]
[Text]
Maybe Bool
Maybe String
Maybe Text
Map ApplyCLIFlag (Map FlagName Bool)
ghciOnlyMain :: Bool
ghciNoBuild :: Bool
ghciHidePackages :: Maybe Bool
ghciSkipIntermediate :: Bool
ghciLoadLocalDeps :: Bool
ghciMainIs :: Maybe Text
ghciAdditionalPackages :: [String]
ghciNoLoadModules :: Bool
ghciGhcCommand :: Maybe String
ghciFlags :: Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: [String]
ghciArgs :: [String]
ghciTargets :: [Text]
ghciOnlyMain :: GhciOpts -> Bool
ghciNoBuild :: GhciOpts -> Bool
ghciHidePackages :: GhciOpts -> Maybe Bool
ghciSkipIntermediate :: GhciOpts -> Bool
ghciLoadLocalDeps :: GhciOpts -> Bool
ghciMainIs :: GhciOpts -> Maybe Text
ghciAdditionalPackages :: GhciOpts -> [String]
ghciNoLoadModules :: GhciOpts -> Bool
ghciGhcCommand :: GhciOpts -> Maybe String
ghciFlags :: GhciOpts -> Map ApplyCLIFlag (Map FlagName Bool)
ghciGhcOptions :: GhciOpts -> [String]
ghciArgs :: GhciOpts -> [String]
ghciTargets :: GhciOpts -> [Text]
..} [(PackageName, (Path Abs File, Target))]
targets Maybe (Path Abs File)
mainFile [GhciPkgInfo]
pkgs [Path Abs File]
extraFiles [PackageName]
exposePackages = do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
let pkgopts :: [String]
pkgopts = [String]
hidePkgOpts forall a. [a] -> [a] -> [a]
++ [String]
genOpts forall a. [a] -> [a] -> [a]
++ [String]
ghcOpts
shouldHidePackages :: Bool
shouldHidePackages =
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
exposePackages)) Maybe Bool
ghciHidePackages
hidePkgOpts :: [String]
hidePkgOpts =
if Bool
shouldHidePackages
then
[String
"-hide-all-packages"] forall a. [a] -> [a] -> [a]
++
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
targets then [String
"-package", String
"base"] else []) forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\PackageName
n -> [String
"-package", PackageName -> String
packageNameString PackageName
n]) [PackageName]
exposePackages
else []
oneWordOpts :: BuildInfoOpts -> [String]
oneWordOpts BuildInfoOpts
bio
| Bool
shouldHidePackages = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioPackageFlags BuildInfoOpts
bio
| Bool
otherwise = BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio
genOpts :: [String]
genOpts = forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
oneWordOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs)
([String]
omittedOpts, [String]
ghcOpts) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition String -> Bool
badForGhci forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfoOpts -> [String]
bioOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts) [GhciPkgInfo]
pkgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
( forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config)
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName -> [Text]
getUserOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs
)
getUserOptions :: PackageName -> [Text]
getUserOptions PackageName
pkg = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] PackageName
pkg (Config -> Map PackageName [Text]
configGhcOptionsByName Config
config)
badForGhci :: String -> Bool
badForGhci String
x =
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"-O" String
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x (String -> [String]
words String
"-debug -threaded -ticky -static -Werror")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
omittedOpts) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"The following GHC options are incompatible with GHCi and \
\have not been passed to it:"
forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False
(forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => String -> a
fromString (forall a. Ord a => [a] -> [a]
nubOrd [String]
omittedOpts) :: [StyleDoc])
)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
Path Abs Dir
oiDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
objectInterfaceDirL
let odir :: [String]
odir =
[ String
"-odir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir
, String
"-hidir=" forall a. Semigroup a => a -> a -> a
<> forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
oiDir ]
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
( String -> StyleDoc
flow String
"Configuring GHCi with the following packages:"
forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Current) Bool
False
(forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> PackageName
ghciPkgName) [GhciPkgInfo]
pkgs :: [StyleDoc])
)
String
compilerExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompilerforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to forall b t. Path b t -> String
toFilePath
let execGhci :: [String] -> RIO env b
execGhci [String]
extras = do
ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
forall {a}. RIO env a -> RIO env a
withPackageWorkingDir forall a b. (a -> b) -> a -> b
$ forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec
(forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand)
((String
"--interactive" : ) forall a b. (a -> b) -> a -> b
$
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GhciPkgInfo]
pkgs then forall a. a -> a
id else (String
"-i" : )) forall a b. (a -> b) -> a -> b
$
[String]
odir forall a. Semigroup a => a -> a -> a
<> [String]
pkgopts forall a. Semigroup a => a -> a -> a
<> [String]
extras forall a. Semigroup a => a -> a -> a
<> [String]
ghciGhcOptions forall a. Semigroup a => a -> a -> a
<> [String]
ghciArgs)
withPackageWorkingDir :: RIO env a -> RIO env a
withPackageWorkingDir =
case [GhciPkgInfo]
pkgs of
[GhciPkgInfo
pkg] -> forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
[GhciPkgInfo]
_ -> forall a. a -> a
id
checkIsIntero :: RIO env Bool
checkIsIntero =
case [GhciPkgInfo]
pkgs of
[GhciPkgInfo
_] -> do
ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
String
output <- forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
forall a b. (a -> b) -> a -> b
$ forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine (forall a. a -> Maybe a -> a
fromMaybe String
compilerExeName Maybe String
ghciGhcCommand) [String
"--version"]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Intero" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
output
[GhciPkgInfo]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Path Abs Dir
tmpDirectory <- forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> Maybe (Path Rel Dir) -> m (Path Abs Dir)
getXdgDir XdgDirectory
XdgCache forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just (Path Rel Dir
relDirStackProgName forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGhciScript)
Path Abs Dir
ghciDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
ghciDirL
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
ghciDir
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
tmpDirectory
[String]
macrosOptions <- forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
ghciDir [GhciPkgInfo]
pkgs
if Bool
ghciNoLoadModules
then forall {b}. [String] -> RIO env b
execGhci [String]
macrosOptions
else do
forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs
Bool
isIntero <- RIO env Bool
checkIsIntero
[String]
scriptOptions <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
tmpDirectory (Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
ghciOnlyMain [Path Abs File]
extraFiles)
forall {b}. [String] -> RIO env b
execGhci ([String]
macrosOptions forall a. [a] -> [a] -> [a]
++ [String]
scriptOptions)
writeMacrosFile ::
HasTerm env
=> Path Abs Dir
-> [GhciPkgInfo]
-> RIO env [String]
writeMacrosFile :: forall env.
HasTerm env =>
Path Abs Dir -> [GhciPkgInfo] -> RIO env [String]
writeMacrosFile Path Abs Dir
outputDirectory [GhciPkgInfo]
pkgs = do
[Path Abs File]
fps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgInfo]
pkgs forall a b. (a -> b) -> a -> b
$ \GhciPkgInfo
pkg -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts GhciPkgInfo
pkg) forall a b. (a -> b) -> a -> b
$ \(NamedComponent
_, BuildInfoOpts
bio) -> do
let cabalMacros :: Path Abs File
cabalMacros = BuildInfoOpts -> Path Abs File
bioCabalMacros BuildInfoOpts
bio
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
cabalMacros
if Bool
exists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
cabalMacros
else do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL [StyleDoc
"Didn't find expected autogen file:", forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalMacros]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[ByteString]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ByteString
S8.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
fps
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
files then forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else do
Path Abs File
out <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileCabalMacrosH forall a b. (a -> b) -> a -> b
$
[ByteString] -> ByteString
S8.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Semigroup a => a -> a -> a
<> ByteString
"\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") [ByteString]
files
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-optP-include", String
"-optP" forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> String
toFilePath Path Abs File
out]
writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String]
writeGhciScript :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> GhciScript -> m [String]
writeGhciScript Path Abs Dir
outputDirectory GhciScript
script = do
Path Abs File
scriptPath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFileGhciScript forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ GhciScript -> ByteString
scriptToLazyByteString GhciScript
script
let scriptFilePath :: String
scriptFilePath = forall b t. Path b t -> String
toFilePath Path Abs File
scriptPath
forall (m :: * -> *). MonadIO m => String -> m ()
setScriptPerms String
scriptFilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-ghci-script=" forall a. Semigroup a => a -> a -> a
<> String
scriptFilePath]
writeHashedFile ::
Path Abs Dir
-> Path Rel File
-> ByteString
-> IO (Path Abs File)
writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File)
writeHashedFile Path Abs Dir
outputDirectory Path Rel File
relFile ByteString
contents = do
Path Rel Dir
relSha <- forall t (m :: * -> *).
(IsPath Rel t, MonadThrow m) =>
ByteString -> m (Path Rel t)
shaPathForBytes ByteString
contents
let outDir :: Path Abs Dir
outDir = Path Abs Dir
outputDirectory forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relSha
outFile :: Path Abs File
outFile = Path Abs Dir
outDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Bool
alreadyExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
outFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outDir
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outFile forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
contents
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outFile
renderScript ::
Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript :: Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript Bool
isIntero [GhciPkgInfo]
pkgs Maybe (Path Abs File)
mainFile Bool
onlyMain [Path Abs File]
extraFiles = do
let cdPhase :: GhciScript
cdPhase = case (Bool
isIntero, [GhciPkgInfo]
pkgs) of
(Bool
True, [GhciPkgInfo
pkg]) -> Path Abs Dir -> GhciScript
cmdCdGhc (GhciPkgInfo -> Path Abs Dir
ghciPkgDir GhciPkgInfo
pkg)
(Bool, [GhciPkgInfo])
_ -> forall a. Monoid a => a
mempty
addPhase :: GhciScript
addPhase = Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ModuleName]
allModules forall a. [a] -> [a] -> [a]
++ forall {a}. [Either a (Path Abs File)]
addMain)
addMain :: [Either a (Path Abs File)]
addMain = case Maybe (Path Abs File)
mainFile of
Just Path Abs File
path -> [forall a b. b -> Either a b
Right Path Abs File
path]
Maybe (Path Abs File)
_ -> []
modulePhase :: GhciScript
modulePhase = Set ModuleName -> GhciScript
cmdModule forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
allModules
allModules :: [ModuleName]
allModules = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> ModuleMap
ghciPkgModules) [GhciPkgInfo]
pkgs
case [GhciPkgInfo] -> [Path Abs File]
getFileTargets [GhciPkgInfo]
pkgs forall a. Semigroup a => a -> a -> a
<> [Path Abs File]
extraFiles of
[] ->
if Bool
onlyMain
then GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> if forall a. Maybe a -> Bool
isJust Maybe (Path Abs File)
mainFile then Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList forall {a}. [Either a (Path Abs File)]
addMain) else forall a. Monoid a => a
mempty
else GhciScript
cdPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
addPhase forall a. Semigroup a => a -> a -> a
<> GhciScript
modulePhase
[Path Abs File]
fileTargets -> Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Path Abs File]
fileTargets))
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciPkgInfo -> Maybe [Path Abs File]
ghciPkgTargetFiles)
figureOutMainFile ::
(HasRunner env, HasTerm env)
=> BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile :: forall env.
(HasRunner env, HasTerm env) =>
BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile BuildOpts
bopts Maybe (Map PackageName Target)
mainIsTargets [(PackageName, (Path Abs File, Target))]
targets0 [GhciPkgInfo]
packages =
case [(PackageName, NamedComponent, Path Abs File)]
candidates of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
_,NamedComponent
_,Path Abs File
fp)] -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Using"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, StyleDoc
"module:"
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate (PackageName, NamedComponent, Path Abs File)
c
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
fp)
(PackageName, NamedComponent, Path Abs File)
candidate:[(PackageName, NamedComponent, Path Abs File)]
_ -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"The"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, String -> StyleDoc
flow String
"module to load is ambiguous. Candidates are:"
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate [(PackageName, NamedComponent, Path Abs File)]
candidates))
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"You can specify which one to pick by:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
[ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Specifying targets to"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack ghci")
, StyleDoc
"e.g."
, Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"stack ghci"
, forall {a} {c}.
(Semigroup a, IsString a) =>
(PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName, NamedComponent, Path Abs File)
candidate
]
) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
, [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Specifying what the"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"main"
, String -> StyleDoc
flow String
"is e.g."
, Style -> StyleDoc -> StyleDoc
style Style
Shell ( [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"stack ghci"
, forall {c}. (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName, NamedComponent, Path Abs File)
candidate
]
) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
, String -> StyleDoc
flow
forall a b. (a -> b) -> a -> b
$ String
"Choosing from the candidate above [1.."
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates)
forall a. Semigroup a => a -> a -> a
<> String
"]."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Path Abs File))
userOption
where
targets :: Map PackageName Target
targets = forall a. a -> Maybe a -> a
fromMaybe (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
k, (Path Abs File
_, Target
x)) -> (PackageName
k, Target
x)) [(PackageName, (Path Abs File, Target))]
targets0)
Maybe (Map PackageName Target)
mainIsTargets
candidates :: [(PackageName, NamedComponent, Path Abs File)]
candidates = do
GhciPkgInfo
pkg <- [GhciPkgInfo]
packages
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg) Map PackageName Target
targets of
Maybe Target
Nothing -> []
Just Target
target -> do
(NamedComponent
component,[Path Abs File]
mains) <-
forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k [Path Abs File]
_ -> NamedComponent
k forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
wantedComponents)
(GhciPkgInfo -> Map NamedComponent [Path Abs File]
ghciPkgMainIs GhciPkgInfo
pkg)
Path Abs File
main <- [Path Abs File]
mains
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg, NamedComponent
component, Path Abs File
main)
where
wantedComponents :: Set NamedComponent
wantedComponents =
BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target (GhciPkgInfo -> Package
ghciPkgPackage GhciPkgInfo
pkg)
renderCandidate :: (PackageName, NamedComponent, Path Abs File) -> StyleDoc
renderCandidate c :: (PackageName, NamedComponent, Path Abs File)
c@(PackageName
pkgName, NamedComponent
namedComponent, Path Abs File
mainIs) =
let candidateIndex :: [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex =
forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (PackageName, NamedComponent, Path Abs File)
c
pkgNameText :: StyleDoc
pkgNameText = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkgName
in Int -> StyleDoc -> StyleDoc
hang Int
4
forall a b. (a -> b) -> a -> b
$ Int -> StyleDoc -> StyleDoc
fill Int
4 ( [(PackageName, NamedComponent, Path Abs File)] -> StyleDoc
candidateIndex [(PackageName, NamedComponent, Path Abs File)]
candidates forall a. Semigroup a => a -> a -> a
<> StyleDoc
".")
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"Package"
, Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
pkgNameText forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, StyleDoc
"component"
, Style -> StyleDoc -> StyleDoc
style
Style
PkgComponent
( StyleDoc
pkgNameText
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
namedComponent
)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, StyleDoc
"with"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"main-is"
, StyleDoc
"file:"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
mainIs forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
candidateIndices :: [Int]
candidateIndices = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PackageName, NamedComponent, Path Abs File)]
candidates) [Int
1 :: Int ..]
userOption :: IO (Maybe (Path Abs File))
userOption = do
Text
option <- forall (m :: * -> *). MonadIO m => Text -> m Text
prompt Text
"Specify main module to use (press enter to load none): "
let selected :: Int
selected = forall a. a -> Maybe a -> a
fromMaybe
((forall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
candidateIndices)
(forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
option) :: Maybe Int)
case forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
selected [Int]
candidateIndices of
Maybe Int
Nothing -> do
String -> IO ()
putStrLn
String
"Not loading any main modules, as no valid module selected"
String -> IO ()
putStrLn String
""
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just Int
op -> do
let (PackageName
_,NamedComponent
_,Path Abs File
fp) = [(PackageName, NamedComponent, Path Abs File)]
candidates forall a. [a] -> Int -> a
L.!! Int
op
String -> IO ()
putStrLn
(String
"Loading main module from candidate " forall a. Semigroup a => a -> a -> a
<>
forall a. Show a => a -> String
show (Int
op forall a. Num a => a -> a -> a
+ Int
1) forall a. Semigroup a => a -> a -> a
<> String
", --main-is " forall a. Semigroup a => a -> a -> a
<>
forall b t. Path b t -> String
toFilePath Path Abs File
fp)
String -> IO ()
putStrLn String
""
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
fp
renderComp :: NamedComponent -> a
renderComp NamedComponent
c =
case NamedComponent
c of
NamedComponent
CLib -> a
"lib"
CInternalLib Text
name -> a
"internal-lib:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
CExe Text
name -> a
"exe:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
CTest Text
name -> a
"test:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString ( Text -> String
T.unpack Text
name)
CBench Text
name -> a
"bench:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
sampleTargetArg :: (PackageName, NamedComponent, c) -> a
sampleTargetArg (PackageName
pkg, NamedComponent
comp, c
_) =
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg)
forall a. Semigroup a => a -> a -> a
<> a
":"
forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
comp
sampleMainIsArg :: (PackageName, NamedComponent, c) -> StyleDoc
sampleMainIsArg (PackageName
pkg, NamedComponent
comp, c
_) =
[StyleDoc] -> StyleDoc
fillSep
[ StyleDoc
"--main-is"
, forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pkg) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => NamedComponent -> a
renderComp NamedComponent
comp
]
loadGhciPkgDescs ::
HasEnvConfig env
=> BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs BuildOptsCLI
buildOptsCLI [(PackageName, (Path Abs File, Target))]
localTargets =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PackageName, (Path Abs File, Target))]
localTargets forall a b. (a -> b) -> a -> b
$ \(PackageName
name, (Path Abs File
cabalfp, Target
target)) ->
forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalfp Target
target
loadGhciPkgDesc ::
HasEnvConfig env
=> BuildOptsCLI
-> PackageName
-> Path Abs File
-> Target
-> RIO env GhciPkgDesc
loadGhciPkgDesc :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> PackageName -> Path Abs File -> Target -> RIO env GhciPkgDesc
loadGhciPkgDesc BuildOptsCLI
buildOptsCLI PackageName
name Path Abs File
cabalfp Target
target = do
EnvConfig
econfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
let SourceMap{Map PackageName GlobalPackage
Map PackageName ProjectPackage
Map PackageName DepPackage
ActualCompiler
SMTargets
smTargets :: SourceMap -> SMTargets
smGlobal :: Map PackageName GlobalPackage
smDeps :: Map PackageName DepPackage
smProject :: Map PackageName ProjectPackage
smCompiler :: ActualCompiler
smTargets :: SMTargets
smGlobal :: SourceMap -> Map PackageName GlobalPackage
smDeps :: SourceMap -> Map PackageName DepPackage
smProject :: SourceMap -> Map PackageName ProjectPackage
smCompiler :: SourceMap -> ActualCompiler
..} = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
econfig
sourceMapGhcOptions :: [Text]
sourceMapGhcOptions = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
(CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(CommonPackage -> [Text]
cpGhcOptions forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
sourceMapCabalConfigOpts :: [Text]
sourceMapCabalConfigOpts = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
(CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(CommonPackage -> [Text]
cpCabalConfigOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> CommonPackage
dpCommon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName DepPackage
smDeps)
sourceMapFlags :: Map FlagName Bool
sourceMapFlags =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (CommonPackage -> Map FlagName Bool
cpFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName ProjectPackage
smProject
config :: PackageConfig
config = PackageConfig
{ packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
True
, packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
True
, packageConfigFlags :: Map FlagName Bool
packageConfigFlags =
BuildOptsCLI -> PackageName -> Map FlagName Bool
getLocalFlags BuildOptsCLI
buildOptsCLI PackageName
name forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map FlagName Bool
sourceMapFlags
, packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = [Text]
sourceMapGhcOptions
, packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = [Text]
sourceMapCabalConfigOpts
, packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
, packageConfigPlatform :: Platform
packageConfigPlatform = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL EnvConfig
econfig
}
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
_cabalfp) <-
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
GenericPackageDescription
gpkgdesc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
Path Rel File
buildinfofp <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++ String
".buildinfo")
Bool
hasDotBuildinfo <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
let mbuildinfofp :: Maybe (Path Abs File)
mbuildinfofp
| Bool
hasDotBuildinfo = forall a. a -> Maybe a
Just (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
buildinfofp)
| Bool
otherwise = forall a. Maybe a
Nothing
Maybe HookedBuildInfo
mbuildinfo <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Path Abs File)
mbuildinfofp forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m HookedBuildInfo
readDotBuildinfo
let pdp :: PackageDescriptionPair
pdp = PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpkgdesc
pkg :: Package
pkg =
PackageConfig -> [PackageFlag] -> PackageDescriptionPair -> Package
packageFromPackageDescription PackageConfig
config (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpkgdesc) forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
PackageDescriptionPair
pdp
(\HookedBuildInfo
bi ->
let PackageDescriptionPair PackageDescription
x PackageDescription
y = PackageDescriptionPair
pdp
in PackageDescription -> PackageDescription -> PackageDescriptionPair
PackageDescriptionPair
(HookedBuildInfo -> PackageDescription -> PackageDescription
C.updatePackageDescription HookedBuildInfo
bi PackageDescription
x)
(HookedBuildInfo -> PackageDescription -> PackageDescription
C.updatePackageDescription HookedBuildInfo
bi PackageDescription
y))
Maybe HookedBuildInfo
mbuildinfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgDesc
{ ghciDescPkg :: Package
ghciDescPkg = Package
pkg
, ghciDescCabalFp :: Path Abs File
ghciDescCabalFp = Path Abs File
cabalfp
, ghciDescTarget :: Target
ghciDescTarget = Target
target
}
getGhciPkgInfos ::
HasEnvConfig env
=> InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos :: forall env.
HasEnvConfig env =>
InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos InstallMap
installMap [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets [GhciPkgDesc]
localTargets = do
(InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let localLibs :: [PackageName]
localLibs =
[ Package -> PackageName
packageName (GhciPkgDesc -> Package
ghciDescPkg GhciPkgDesc
desc)
| GhciPkgDesc
desc <- [GhciPkgDesc]
localTargets
, (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
isCLib (GhciPkgDesc -> Target
ghciDescTarget GhciPkgDesc
desc)
]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GhciPkgDesc]
localTargets forall a b. (a -> b) -> a -> b
$ \GhciPkgDesc
pkgDesc ->
forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
localLibs [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc
makeGhciPkgInfo ::
HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo :: forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Maybe (Map PackageName [Path Abs File])
mfileTargets GhciPkgDesc
pkgDesc = do
BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
let pkg :: Package
pkg = GhciPkgDesc -> Package
ghciDescPkg GhciPkgDesc
pkgDesc
cabalfp :: Path Abs File
cabalfp = GhciPkgDesc -> Path Abs File
ghciDescCabalFp GhciPkgDesc
pkgDesc
target :: Target
target = GhciPkgDesc -> Target
ghciDescTarget GhciPkgDesc
pkgDesc
name :: PackageName
name = Package -> PackageName
packageName Package
pkg
(Map NamedComponent (Map ModuleName (Path Abs File))
mods,Map NamedComponent [DotCabalPath]
files,Map NamedComponent BuildInfoOpts
opts) <- GetPackageOpts
-> forall env.
HasEnvConfig env =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> RIO
env
(Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath],
Map NamedComponent BuildInfoOpts)
getPackageOpts (Package -> GetPackageOpts
packageOpts Package
pkg) InstallMap
installMap InstalledMap
installedMap [PackageName]
locals [PackageName]
addPkgs Path Abs File
cabalfp
let filteredOpts :: Map NamedComponent BuildInfoOpts
filteredOpts = forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent BuildInfoOpts
opts
filterWanted :: Map NamedComponent a -> Map NamedComponent a
filterWanted = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NamedComponent
k a
_ -> NamedComponent
k forall a. Ord a => a -> Set a -> Bool
`S.member` Set NamedComponent
allWanted)
allWanted :: Set NamedComponent
allWanted = BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
bopts Target
target Package
pkg
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhciPkgInfo
{ ghciPkgName :: PackageName
ghciPkgName = PackageName
name
, ghciPkgOpts :: [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts = forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent BuildInfoOpts
filteredOpts
, ghciPkgDir :: Path Abs Dir
ghciPkgDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp
, ghciPkgModules :: ModuleMap
ghciPkgModules = [ModuleMap] -> ModuleMap
unionModuleMaps forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(NamedComponent
comp, Map ModuleName (Path Abs File)
mp) -> forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\Path Abs File
fp -> forall k a. k -> a -> Map k a
M.singleton Path Abs File
fp (forall a. a -> Set a
S.singleton (Package -> PackageName
packageName Package
pkg, NamedComponent
comp))) Map ModuleName (Path Abs File)
mp)
(forall k a. Map k a -> [(k, a)]
M.toList (forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted Map NamedComponent (Map ModuleName (Path Abs File))
mods))
, ghciPkgMainIs :: Map NamedComponent [Path Abs File]
ghciPkgMainIs = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalMainPath) Map NamedComponent [DotCabalPath]
files
, ghciPkgCFiles :: [Path Abs File]
ghciPkgCFiles = forall a. Monoid a => [a] -> a
mconcat (forall k a. Map k a -> [a]
M.elems (forall {a}. Map NamedComponent a -> Map NamedComponent a
filterWanted (forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath) Map NamedComponent [DotCabalPath]
files)))
, ghciPkgTargetFiles :: Maybe [Path Abs File]
ghciPkgTargetFiles = Maybe (Map PackageName [Path Abs File])
mfileTargets forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name
, ghciPkgPackage :: Package
ghciPkgPackage = Package
pkg
}
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents BuildOpts
_ (TargetComps Set NamedComponent
cs) Package
_ = Set NamedComponent
cs
wantedPackageComponents BuildOpts
bopts (TargetAll PackageType
PTProject) Package
pkg = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$
(case Package -> PackageLibraries
packageLibraries Package
pkg of
PackageLibraries
NoLibraries -> []
HasLibraries Set Text
names -> NamedComponent
CLib forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList Set Text
names)) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CExe (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageExes Package
pkg)) forall a. Semigroup a => a -> a -> a
<>
forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CInternalLib (forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
pkg) forall a. Semigroup a => a -> a -> a
<>
(if BuildOpts -> Bool
boptsTests BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CTest (forall k a. Map k a -> [k]
M.keys (Package -> Map Text TestSuiteInterface
packageTests Package
pkg)) else []) forall a. Semigroup a => a -> a -> a
<>
(if BuildOpts -> Bool
boptsBenchmarks BuildOpts
bopts then forall a b. (a -> b) -> [a] -> [b]
map Text -> NamedComponent
CBench (forall a. Set a -> [a]
S.toList (Package -> Set Text
packageBenchmarks Package
pkg)) else [])
wantedPackageComponents BuildOpts
_ Target
_ Package
_ = forall a. Set a
S.empty
checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues [GhciPkgInfo]
pkgs =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [GhciPkgInfo]
pkgs forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StyleDoc]
cabalFlagIssues) forall a b. (a -> b) -> a -> b
$ do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"There are Cabal flags for this project which may prevent \
\GHCi from loading your code properly. In some cases it \
\can also load some projects which would otherwise fail to \
\build."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse StyleDoc
blankLine [StyleDoc]
cabalFlagIssues)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"To resolve, remove the flag(s) from the Cabal file(s) and \
\instead put them at the top of the Haskell files."
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"It isn't yet possible to load multiple packages into GHCi in \
\all cases. For further information, see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://ghc.haskell.org/trac/ghc/ticket/10827" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
where
cabalFlagIssues :: [StyleDoc]
cabalFlagIssues = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [StyleDoc]) -> [StyleDoc]
mixedFlag
[ ( String
"-XNoImplicitPrelude"
, [ String -> StyleDoc
flow String
"-XNoImplicitPrelude will be used, but GHCi will likely fail to \
\build things which depend on the implicit prelude."
]
)
, ( String
"-XCPP"
, [ String -> StyleDoc
flow String
"-XCPP will be used, but it can cause issues with multiline \
\strings. For further information, see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
)
, ( String
"-XNoTraditionalRecordSyntax"
, [ String -> StyleDoc
flow String
"-XNoTraditionalRecordSyntax will be used, but it break modules \
\which use record syntax."
]
)
, ( String
"-XTemplateHaskell"
, [ String -> StyleDoc
flow String
"-XTemplateHaskell will be used, but it may cause compilation \
\issues due to different parsing of '$' when there's no space \
\after it."
]
)
, ( String
"-XQuasiQuotes"
, [ String -> StyleDoc
flow String
"-XQuasiQuotes will be used, but it may cause parse failures \
\due to a different meaning for list comprehension syntax like \
\[x| ... ]"
]
)
, ( String
"-XSafe"
, [ String -> StyleDoc
flow String
"-XSafe will be used, but it will fail to compile unsafe \
\modules."
]
)
, ( String
"-XArrows"
, [ String -> StyleDoc
flow String
"-XArrows will be used, but it will cause non-arrow usages of \
\proc, (-<), (-<<) to fail"
]
)
, ( String
"-XOverloadedStrings"
, [ String -> StyleDoc
flow String
"-XOverloadedStrings will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( String
"-XOverloadedLists"
, [ String -> StyleDoc
flow String
"-XOverloadedLists will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( String
"-XMonoLocalBinds"
, [ String -> StyleDoc
flow String
"-XMonoLocalBinds will be used, but it can cause type errors in \
\code which expects generalized local bindings." ]
)
, ( String
"-XTypeFamilies"
, [ String -> StyleDoc
flow String
"-XTypeFamilies will be used, but it implies -XMonoLocalBinds, \
\and so can cause type errors in code which expects generalized \
\local bindings." ]
)
, ( String
"-XGADTs"
, [ String -> StyleDoc
flow String
"-XGADTs will be used, but it implies -XMonoLocalBinds, and so \
\can cause type errors in code which expects generalized local \
\bindings." ]
)
, ( String
"-XNewQualifiedOperators"
, [ String -> StyleDoc
flow String
"-XNewQualifiedOperators will be used, but this will break \
\usages of the old qualified operator syntax." ]
)
]
mixedFlag :: (String, [StyleDoc]) -> [StyleDoc]
mixedFlag (String
flag, [StyleDoc]
msgs) =
let x :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x = (String -> Bool)
-> ([(PackageName, NamedComponent)],
[(PackageName, NamedComponent)])
partitionComps (forall a. Eq a => a -> a -> Bool
== String
flag) in
[ [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
msgs forall a. [a] -> [a] -> [a]
++ ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x | forall {a} {a}. (Eq a, Eq a) => ([a], [a]) -> Bool
mixedSettings ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
x ]
mixedSettings :: ([a], [a]) -> Bool
mixedSettings ([a]
xs, [a]
ys) = [a]
xs forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& [a]
ys forall a. Eq a => a -> a -> Bool
/= []
showWhich :: ([(PackageName, NamedComponent)], [(PackageName, NamedComponent)])
-> [StyleDoc]
showWhich ([(PackageName, NamedComponent)]
haveIt, [(PackageName, NamedComponent)]
don'tHaveIt) =
[ String -> StyleDoc
flow String
"It is specified for:" ]
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
(forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
haveIt :: [StyleDoc])
forall a. Semigroup a => a -> a -> a
<> [ String -> StyleDoc
flow String
"But not for:" ]
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
(forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent) [(PackageName, NamedComponent)]
don'tHaveIt :: [StyleDoc])
partitionComps :: (String -> Bool)
-> ([(PackageName, NamedComponent)],
[(PackageName, NamedComponent)])
partitionComps String -> Bool
f = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
xs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((PackageName, NamedComponent), [String])]
ys)
where
([((PackageName, NamedComponent), [String])]
xs, [((PackageName, NamedComponent), [String])]
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((PackageName, NamedComponent), [String])]
compsWithOpts
compsWithOpts :: [((PackageName, NamedComponent), [String])]
compsWithOpts = forall a b. (a -> b) -> [a] -> [b]
map (\((PackageName, NamedComponent)
k, BuildInfoOpts
bio) ->
((PackageName, NamedComponent)
k, BuildInfoOpts -> [String]
bioOneWordOpts BuildInfoOpts
bio forall a. [a] -> [a] -> [a]
++ BuildInfoOpts -> [String]
bioOpts BuildInfoOpts
bio)) [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios
compsWithBios :: [((PackageName, NamedComponent), BuildInfoOpts)]
compsWithBios =
[ ((GhciPkgInfo -> PackageName
ghciPkgName GhciPkgInfo
pkg, NamedComponent
c), BuildInfoOpts
bio)
| GhciPkgInfo
pkg <- [GhciPkgInfo]
pkgs
, (NamedComponent
c, BuildInfoOpts
bio) <- GhciPkgInfo -> [(NamedComponent, BuildInfoOpts)]
ghciPkgOpts GhciPkgInfo
pkg
]
checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules :: forall env. HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules [GhciPkgInfo]
pkgs =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
flow String
"Multiple files use the same module name:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
where
duplicates ::
[(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates :: [(ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates =
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ModuleName
_, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) -> forall k a. Map k a -> Int
M.size Map (Path Abs File) (Set (PackageName, NamedComponent))
mp forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
[ModuleMap] -> ModuleMap
unionModuleMaps (forall a b. (a -> b) -> [a] -> [b]
map GhciPkgInfo -> ModuleMap
ghciPkgModules [GhciPkgInfo]
pkgs)
prettyDuplicate ::
(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate :: (ModuleName,
Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate (ModuleName
mn, Map (Path Abs File) (Set (PackageName, NamedComponent))
mp) =
[StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Error (forall a. Pretty a => a -> StyleDoc
pretty ModuleName
mn)
, String -> StyleDoc
flow String
"found at the following paths"
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) (Set (PackageName, NamedComponent))
mp))
fileDuplicate ::
(Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (Path Abs File
fp, Set (PackageName, NamedComponent)
comps) =
[StyleDoc] -> StyleDoc
fillSep
[ forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fp
, StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," (forall a b. (a -> b) -> [a] -> [b]
map (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent (forall a. Set a -> [a]
S.toList Set (PackageName, NamedComponent)
comps))
]
targetWarnings ::
HasBuildConfig env
=> [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings :: forall env.
HasBuildConfig env =>
[(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings [(PackageName, (Path Abs File, Target))]
localTargets [PackageName]
nonLocalTargets Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
nonLocalTargets) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Some targets"
, StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate StyleDoc
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
Good forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
nonLocalTargets
, String -> StyleDoc
flow String
"are not local packages, and so cannot be directly loaded."
, String -> StyleDoc
flow String
"In future versions of Stack, this might be supported - see"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/1441"
, StyleDoc
"."
, String -> StyleDoc
flow String
"It can still be useful to specify these, as they will be passed to ghci via -package flags."
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, (Path Abs File, Target))]
localTargets Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (Map PackageName [Path Abs File], [Path Abs File])
mfileTargets) forall a b. (a -> b) -> a -> b
$ do
SMWanted
smWanted <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> SMWanted
bcSMWanted
Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep
[ String -> StyleDoc
flow String
"No local targets specified, so a plain ghci will be started with no package hiding or package options."
, StyleDoc
""
, String -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$
Utf8Builder
"You are using snapshot: " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
display (SMWanted -> RawSnapshotLocation
smwSnapshotLocation SMWanted
smWanted)
, StyleDoc
""
, String -> StyleDoc
flow String
"If you want to use package hiding and options, then you can try one of the following:"
, StyleDoc
""
, [StyleDoc] -> StyleDoc
bulletedList
[ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"If you want to start a different project configuration than" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml forall a. Semigroup a => a -> a -> a
<> StyleDoc
", then you can use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack init"
, String -> StyleDoc
flow String
"to create a new stack.yaml for the packages in the current directory."
, StyleDoc
line
]
, String -> StyleDoc
flow String
"If you want to use the project configuration at" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml forall a. Semigroup a => a -> a -> a
<> StyleDoc
", then you can add to its 'packages' field."
]
, StyleDoc
""
]
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 =
forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
(\Map PackageName (Path Abs File, Target)
mp -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map PackageName (Path Abs File, Target)
mp (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PackageName, (Path Abs File, Target))]
targets)) forall a b. (a -> b) -> a -> b
$
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [PackageName]
getDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(PackageName, (Path Abs File, Target))]
targets)
(forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Maybe a
Just) [(PackageName, (Path Abs File, Target))]
targets))
where
getDeps :: PackageName -> [PackageName]
getDeps :: PackageName -> [PackageName]
getDeps PackageName
name =
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap of
Just LocalPackage
lp -> forall k a. Map k a -> [k]
M.keys (Package -> Map PackageName DepValue
packageDeps (LocalPackage -> Package
lpPackage LocalPackage
lp))
Maybe LocalPackage
_ -> []
go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go :: PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go PackageName
name = do
Map PackageName (Maybe (Path Abs File, Target))
cache <- forall s (m :: * -> *). MonadState s m => m s
get
case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName (Maybe (Path Abs File, Target))
cache, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name Map PackageName LocalPackage
localMap) of
(Just (Just (Path Abs File, Target)
_), Maybe LocalPackage
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
(Just Maybe (Path Abs File, Target)
Nothing, Maybe LocalPackage
_) | Bool -> Bool
not Bool
loadAllDeps -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(Maybe (Maybe (Path Abs File, Target))
_, Just LocalPackage
lp) -> do
let deps :: [PackageName]
deps = forall k a. Map k a -> [k]
M.keys (Package -> Map PackageName DepValue
packageDeps (LocalPackage -> Package
lpPackage LocalPackage
lp))
Bool
shouldLoad <- forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageName
-> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go [PackageName]
deps
if Bool
shouldLoad
then do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name (forall a. a -> Maybe a
Just (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp, Set NamedComponent -> Target
TargetComps (forall a. a -> Set a
S.singleton NamedComponent
CLib))))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PackageName
name forall a. Maybe a
Nothing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(Maybe (Maybe (Path Abs File, Target))
_, Maybe LocalPackage
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets :: forall k. Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a b. (a -> b) -> a -> b
$ \Target
l Target
r -> case (Target
l, Target
r) of
(TargetAll PackageType
PTDependency, Target
_) -> Target
r
(TargetComps Set NamedComponent
sl, TargetComps Set NamedComponent
sr) -> Set NamedComponent -> Target
TargetComps (forall a. Ord a => Set a -> Set a -> Set a
S.union Set NamedComponent
sl Set NamedComponent
sr)
(TargetComps Set NamedComponent
_, TargetAll PackageType
PTProject) -> PackageType -> Target
TargetAll PackageType
PTProject
(TargetComps Set NamedComponent
_, Target
_) -> Target
l
(TargetAll PackageType
PTProject, Target
_) -> PackageType -> Target
TargetAll PackageType
PTProject
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp NamedComponent -> Bool
p Target
t = case Target
t of
TargetComps Set NamedComponent
s -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
p (forall a. Set a -> [a]
S.toList Set NamedComponent
s)
TargetAll PackageType
PTProject -> Bool
True
Target
_ -> Bool
False
runGrabFirstLine ::
(HasProcessContext env, HasLogFunc env)
=> String
-> [String]
-> RIO env String
runGrabFirstLine :: forall env.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env String
runGrabFirstLine String
cmd0 [String]
args =
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
cmd0 [String]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> do
(ByteString
out, ByteString
_err) <- forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
pc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
TL.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
TL.concat
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
TL.lines
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
lenientDecode ByteString
out