stack-2.11.1: src/Stack/Ghci.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Types and functions related to Stack's @ghci@ and @repl@ commands.
module Stack.Ghci
( GhciOpts (..)
, GhciPkgInfo (..)
, GhciException (..)
, GhciPrettyException (..)
, ghciCmd
, ghci
) where
import Control.Monad.State.Strict ( State, execState, get, modify )
import Data.ByteString.Builder ( byteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import 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 )
-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Ghci" module.
data GhciException
= InvalidPackageOption String
| LoadingDuplicateModules
| MissingFileTarget String
| Can'tSpecifyFilesAndTargets
| Can'tSpecifyFilesAndMainIs
deriving (Show, Typeable)
instance Exception GhciException where
displayException (InvalidPackageOption name) =
"Error: [S-6716]\n"
++ "Failed to parse '--package' option " ++ name ++ "."
displayException LoadingDuplicateModules = unlines
[ "Error: [S-9632]"
, "Not attempting to start ghci due to these duplicate modules."
, "Use '--no-load' to try to start it anyway, without loading any \
\modules (but these are still likely to cause errors)."
]
displayException (MissingFileTarget name) =
"Error: [S-3600]\n"
++ "Cannot find file target " ++ name ++ "."
displayException Can'tSpecifyFilesAndTargets =
"Error: [S-9906]\n"
++ "Cannot use 'stack ghci' with both file targets and package targets."
displayException Can'tSpecifyFilesAndMainIs =
"Error: [S-5188]\n"
++ "Cannot use 'stack ghci' with both file targets and '--main-is' \
\flag."
-- | Type representing \'pretty\' exceptions thrown by functions exported by the
-- "Stack.Ghci" module.
newtype GhciPrettyException
= GhciTargetParseException [StyleDoc]
deriving (Show, Typeable)
instance Pretty GhciPrettyException where
pretty (GhciTargetParseException errs) =
"[S-6948]"
<> pprintTargetParseErrors errs
<> blankLine
<> fillSep
[ flow "Note that to specify options to be passed to GHCi, use the"
, style Shell "--ghci-options"
, "option."
]
instance Exception GhciPrettyException
-- | Typre respresenting command line options for the @stack ghci@ and
-- @stack repl@ commands.
data GhciOpts = GhciOpts
{ ghciTargets :: ![Text]
, ghciArgs :: ![String]
, ghciGhcOptions :: ![String]
, ghciFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
, ghciGhcCommand :: !(Maybe FilePath)
, ghciNoLoadModules :: !Bool
, ghciAdditionalPackages :: ![String]
, ghciMainIs :: !(Maybe Text)
, ghciLoadLocalDeps :: !Bool
, ghciSkipIntermediate :: !Bool
, ghciHidePackages :: !(Maybe Bool)
, ghciNoBuild :: !Bool
, ghciOnlyMain :: !Bool
}
deriving Show
-- | Type representing information required to load a package or its components.
--
-- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order
-- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786
data GhciPkgInfo = GhciPkgInfo
{ ghciPkgName :: !PackageName
, ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)]
, ghciPkgDir :: !(Path Abs Dir)
, ghciPkgModules :: !ModuleMap
, ghciPkgCFiles :: ![Path Abs File] -- ^ C files.
, ghciPkgMainIs :: !(Map NamedComponent [Path Abs File])
, ghciPkgTargetFiles :: !(Maybe [Path Abs File])
, ghciPkgPackage :: !Package
}
deriving Show
-- | Type representing loaded package description and related information.
data GhciPkgDesc = GhciPkgDesc
{ ghciDescPkg :: !Package
, ghciDescCabalFp :: !(Path Abs File)
, ghciDescTarget :: !Target
}
-- Mapping from a module name to a map with all of the paths that use
-- that name. Each of those paths is associated with a set of components
-- that contain it. Purpose of this complex structure is for use in
-- 'checkForDuplicateModules'.
type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent)))
unionModuleMaps :: [ModuleMap] -> ModuleMap
unionModuleMaps = M.unionsWith (M.unionWith S.union)
-- | Function underlying the @stack ghci@ and @stack repl@ commands. Run GHCi in
-- the context of a project.
ghciCmd :: GhciOpts -> RIO Runner ()
ghciCmd ghciOpts =
let boptsCLI = defaultBuildOptsCLI
-- using only additional packages, targets then get overridden in `ghci`
{ boptsCLITargets = map T.pack (ghciAdditionalPackages ghciOpts)
, boptsCLIInitialBuildSteps = True
, boptsCLIFlags = ghciFlags ghciOpts
, boptsCLIGhcOptions = map T.pack (ghciGhcOptions ghciOpts)
}
in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
bopts <- view buildOptsL
-- override env so running of tests and benchmarks is disabled
let boptsLocal = bopts
{ boptsTestOpts = (boptsTestOpts bopts) { toDisableRun = True }
, boptsBenchmarkOpts =
(boptsBenchmarkOpts bopts) { beoDisableRun = True }
}
local (set buildOptsL boptsLocal) (ghci ghciOpts)
-- | Launch a GHCi session for the given local package targets with the
-- given options and configure it with the load paths and extensions
-- of those targets.
ghci :: HasEnvConfig env => GhciOpts -> RIO env ()
ghci opts@GhciOpts{..} = do
let buildOptsCLI = defaultBuildOptsCLI
{ boptsCLITargets = []
, boptsCLIFlags = ghciFlags
}
sourceMap <- view $ envConfigL.to envConfigSourceMap
installMap <- toInstallMap sourceMap
locals <- projectLocalPackages
depLocals <- localDependencies
let localMap =
M.fromList [(packageName $ lpPackage lp, lp) | lp <- locals ++ depLocals]
-- FIXME:qrilka this looks wrong to go back to SMActual
sma = SMActual
{ smaCompiler = smCompiler sourceMap
, smaProject = smProject sourceMap
, smaDeps = smDeps sourceMap
, smaGlobal = smGlobal sourceMap
}
-- Parse --main-is argument.
mainIsTargets <- parseMainIsTargets buildOptsCLI sma ghciMainIs
-- Parse to either file targets or build targets
etargets <- preprocessTargets buildOptsCLI sma ghciTargets
(inputTargets, mfileTargets) <- case etargets of
Right packageTargets -> pure (packageTargets, Nothing)
Left rawFileTargets -> do
case mainIsTargets of
Nothing -> pure ()
Just _ -> throwM Can'tSpecifyFilesAndMainIs
-- Figure out targets based on filepath targets
(targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets
pure (targetMap, Just (fileInfo, extraFiles))
-- Get a list of all the local target packages.
localTargets <- getAllLocalTargets opts inputTargets mainIsTargets localMap
-- Get a list of all the non-local target packages.
nonLocalTargets <- getAllNonLocalTargets inputTargets
-- Check if additional package arguments are sensible.
addPkgs <- checkAdditionalPackages ghciAdditionalPackages
-- Load package descriptions.
pkgDescs <- loadGhciPkgDescs buildOptsCLI localTargets
-- If necessary, ask user about which main module to load.
bopts <- view buildOptsL
mainFile <- if ghciNoLoadModules
then pure Nothing
else do
-- Figure out package files, in order to ask the user about which main
-- module to load. See the note below for why this is done again after the
-- build. This could potentially be done more efficiently, because all we
-- need is the location of main modules, not the rest.
pkgs0 <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs
figureOutMainFile bopts mainIsTargets localTargets pkgs0
let pkgTargets pn targets =
case targets of
TargetAll _ -> [T.pack (packageNameString pn)]
TargetComps comps -> [renderPkgComponent (pn, c) | c <- toList comps]
-- Build required dependencies and setup local packages.
buildDepsAndInitialSteps opts $
concatMap (\(pn, (_, t)) -> pkgTargets pn t) localTargets
targetWarnings localTargets nonLocalTargets mfileTargets
-- Load the list of modules _after_ building, to catch changes in
-- unlisted dependencies (#1180)
pkgs <- getGhciPkgInfos installMap addPkgs (fmap fst mfileTargets) pkgDescs
checkForIssues pkgs
-- Finally, do the invocation of ghci
runGhci
opts
localTargets
mainFile
pkgs
(maybe [] snd mfileTargets)
(nonLocalTargets ++ addPkgs)
preprocessTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> [Text]
-> RIO env (Either [Path Abs File] (Map PackageName Target))
preprocessTargets buildOptsCLI sma rawTargets = do
let (fileTargetsRaw, normalTargetsRaw) =
L.partition
(\t -> ".hs" `T.isSuffixOf` t || ".lhs" `T.isSuffixOf` t)
rawTargets
-- Only use file targets if we have no normal targets.
if not (null fileTargetsRaw) && null normalTargetsRaw
then do
fileTargets <- forM fileTargetsRaw $ \fp0 -> do
let fp = T.unpack fp0
mpath <- forgivingResolveFile' fp
case mpath of
Nothing -> throwM (MissingFileTarget fp)
Just path -> pure path
pure (Left fileTargets)
else do
-- Try parsing targets before checking if both file and
-- module targets are specified (see issue#3342).
let boptsCLI = buildOptsCLI { boptsCLITargets = normalTargetsRaw }
normalTargets <- parseTargets AllowNoTargets False boptsCLI sma
`catch` \pex@(PrettyException ex) ->
case fromException $ toException ex of
Just (TargetParseException xs) ->
prettyThrowM $ GhciTargetParseException xs
_ -> throwM pex
unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets
pure (Right $ smtTargets normalTargets)
parseMainIsTargets ::
HasEnvConfig env
=> BuildOptsCLI
-> SMActual GlobalPackage
-> Maybe Text
-> RIO env (Maybe (Map PackageName Target))
parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do
let boptsCLI = buildOptsCLI { boptsCLITargets = [target] }
targets <- parseTargets AllowNoTargets False boptsCLI sma
pure $ smtTargets targets
-- | Display PackageName + NamedComponent
displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc
displayPkgComponent =
style PkgComponent . fromString . T.unpack . renderPkgComponent
findFileTargets ::
HasEnvConfig env
=> [LocalPackage]
-> [Path Abs File]
-> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File])
findFileTargets locals fileTargets = do
filePackages <- forM locals $ \lp -> do
(_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp)
pure (lp, M.map (map dotCabalGetPath) compFiles)
let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
foundFileTargetComponents =
map (\fp -> (fp, ) $ L.sort $
concatMap (\(lp, files) -> map ((packageName (lpPackage lp), ) . fst)
(filter (elem fp . snd) (M.toList files))
) filePackages
) fileTargets
results <- forM foundFileTargetComponents $ \(fp, xs) ->
case xs of
[] -> do
prettyWarnL
[ flow "Couldn't find a component for file target"
, pretty fp <> "."
, flow "This means that the correct GHC options might not be used. \
\Attempting to load the file anyway."
]
pure $ Left fp
[x] -> do
prettyInfoL
[ flow "Using configuration for"
, displayPkgComponent x
, flow "to load"
, pretty fp
]
pure $ Right (fp, x)
(x:_) -> do
prettyWarn $
fillSep
[ flow "Multiple components contain file target"
, pretty fp <> ":"
, fillSep $ punctuate "," (map displayPkgComponent xs)
]
<> line
<> fillSep
[ flow "Guessing the first one,"
, displayPkgComponent x <> "."
]
pure $ Right (fp, x)
let (extraFiles, associatedFiles) = partitionEithers results
targetMap =
foldl unionTargets M.empty $
map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp)))
associatedFiles
infoMap =
foldl (M.unionWith (<>)) M.empty $
map (\(fp, (name, _)) -> M.singleton name [fp])
associatedFiles
pure (targetMap, infoMap, extraFiles)
getAllLocalTargets ::
HasEnvConfig env
=> GhciOpts
-> Map PackageName Target
-> Maybe (Map PackageName Target)
-> Map PackageName LocalPackage
-> RIO env [(PackageName, (Path Abs File, Target))]
getAllLocalTargets GhciOpts{..} targets0 mainIsTargets localMap = do
-- Use the 'mainIsTargets' as normal targets, for CLI concision. See
-- #1845. This is a little subtle - we need to do the target parsing
-- independently in order to handle the case where no targets are
-- specified.
let targets = maybe targets0 (unionTargets targets0) mainIsTargets
packages <- view $ envConfigL.to envConfigSourceMap.to smProject
-- Find all of the packages that are directly demanded by the
-- targets.
let directlyWanted = flip mapMaybe (M.toList packages) $
\(name, pp) ->
case M.lookup name targets of
Just simpleTargets -> Just (name, (ppCabalFP pp, simpleTargets))
Nothing -> Nothing
-- Figure out
let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps localMap directlyWanted
if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps
then pure directlyWanted
else do
let extraList' =
map (fromString . packageNameString . fst) extraLoadDeps :: [StyleDoc]
extraList = mkNarrativeList (Just Current) False extraList'
if ghciLoadLocalDeps
then prettyInfo $
fillSep $
[ flow "The following libraries will also be loaded into \
\GHCi because they are local dependencies of your \
\targets, and you specified"
, style Shell "--load-local-deps" <> ":"
]
<> extraList
else prettyInfo $
fillSep
( flow "The following libraries will also be loaded into \
\GHCi because they are intermediate dependencies of \
\your targets:"
: extraList
)
<> line
<> fillSep
[ "(Use"
, style Shell "--skip-intermediate-deps"
, flow "to omit these.)"
]
pure (directlyWanted ++ extraLoadDeps)
getAllNonLocalTargets ::
Map PackageName Target
-> RIO env [PackageName]
getAllNonLocalTargets targets = do
let isNonLocal (TargetAll PTDependency) = True
isNonLocal _ = False
pure $ map fst $ filter (isNonLocal . snd) (M.toList targets)
buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env ()
buildDepsAndInitialSteps GhciOpts{..} localTargets = do
let targets = localTargets ++ map T.pack ghciAdditionalPackages
-- If necessary, do the build, for local packagee targets, only do
-- 'initialBuildSteps'.
case NE.nonEmpty targets of
-- only new local targets could appear here
Just nonEmptyTargets | not ghciNoBuild -> do
eres <- buildLocalTargets nonEmptyTargets
case eres of
Right () -> pure ()
Left err -> do
case fromException err of
Just (PrettyException prettyErr) -> prettyError $ pretty prettyErr
Nothing -> prettyError $ fromString (displayException err)
prettyWarn "Build failed, but trying to launch GHCi anyway"
_ ->
pure ()
checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName]
checkAdditionalPackages pkgs = forM pkgs $ \name -> do
let mres = (pkgName <$> parsePackageIdentifier name)
<|> parsePackageNameThrowing name
maybe (throwM $ InvalidPackageOption name) pure mres
runGhci ::
HasEnvConfig env
=> GhciOpts
-> [(PackageName, (Path Abs File, Target))]
-> Maybe (Path Abs File)
-> [GhciPkgInfo]
-> [Path Abs File]
-> [PackageName]
-> RIO env ()
runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do
config <- view configL
let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts
shouldHidePackages =
fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages
hidePkgOpts =
if shouldHidePackages
then
["-hide-all-packages"] ++
-- This is necessary, because current versions of ghci
-- will entirely fail to start if base isn't visible. This
-- is because it tries to use the interpreter to set
-- buffering options on standard IO.
(if null targets then ["-package", "base"] else []) ++
concatMap (\n -> ["-package", packageNameString n]) exposePackages
else []
oneWordOpts bio
| shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio
| otherwise = bioOneWordOpts bio
genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs)
(omittedOpts, ghcOpts) = L.partition badForGhci $
concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ map T.unpack
( fold (configGhcOptionsByCat config) -- include everything, locals, and targets
++ concatMap (getUserOptions . ghciPkgName) pkgs
)
getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config)
badForGhci x =
L.isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror")
unless (null omittedOpts) $
prettyWarn $
fillSep
( flow "The following GHC options are incompatible with GHCi and \
\have not been passed to it:"
: mkNarrativeList (Just Current) False
(map fromString (nubOrd omittedOpts) :: [StyleDoc])
)
<> line
oiDir <- view objectInterfaceDirL
let odir =
[ "-odir=" <> toFilePathNoTrailingSep oiDir
, "-hidir=" <> toFilePathNoTrailingSep oiDir ]
prettyInfoL
( flow "Configuring GHCi with the following packages:"
: mkNarrativeList (Just Current) False
(map (fromString . packageNameString . ghciPkgName) pkgs :: [StyleDoc])
)
compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath
let execGhci extras = do
menv <- liftIO $ configProcessContextSettings config defaultEnvSettings
withPackageWorkingDir $ withProcessContext menv $ exec
(fromMaybe compilerExeName ghciGhcCommand)
(("--interactive" : ) $
-- This initial "-i" resets the include directories to
-- not include CWD. If there aren't any packages, CWD
-- is included.
(if null pkgs then id else ("-i" : )) $
odir <> pkgopts <> extras <> ghciGhcOptions <> ghciArgs)
withPackageWorkingDir =
case pkgs of
[pkg] -> withWorkingDir (toFilePath $ ghciPkgDir pkg)
_ -> id
-- TODO: Consider optimizing this check. Perhaps if no
-- "with-ghc" is specified, assume that it is not using intero.
checkIsIntero =
-- Optimization dependent on the behavior of renderScript -
-- it doesn't matter if it's intero or ghci when loading
-- multiple packages.
case pkgs of
[_] -> do
menv <- liftIO $ configProcessContextSettings config defaultEnvSettings
output <- withProcessContext menv
$ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"]
pure $ "Intero" `L.isPrefixOf` output
_ -> pure False
-- Since usage of 'exec' does not pure, we cannot do any cleanup
-- on ghci exit. So, instead leave the generated files. To make this
-- more efficient and avoid gratuitous generation of garbage, the
-- file names are determined by hashing. This also has the nice side
-- effect of making it possible to copy the ghci invocation out of
-- the log and have it still work.
tmpDirectory <- getXdgDir XdgCache $
Just (relDirStackProgName </> relDirGhciScript)
ghciDir <- view ghciDirL
ensureDir ghciDir
ensureDir tmpDirectory
macrosOptions <- writeMacrosFile ghciDir pkgs
if ghciNoLoadModules
then execGhci macrosOptions
else do
checkForDuplicateModules pkgs
isIntero <- checkIsIntero
scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles)
execGhci (macrosOptions ++ scriptOptions)
writeMacrosFile ::
HasTerm env
=> Path Abs Dir
-> [GhciPkgInfo]
-> RIO env [String]
writeMacrosFile outputDirectory pkgs = do
fps <- fmap (nubOrd . catMaybes . concat) $
forM pkgs $ \pkg -> forM (ghciPkgOpts pkg) $ \(_, bio) -> do
let cabalMacros = bioCabalMacros bio
exists <- liftIO $ doesFileExist cabalMacros
if exists
then pure $ Just cabalMacros
else do
prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros]
pure Nothing
files <- liftIO $ mapM (S8.readFile . toFilePath) fps
if null files then pure [] else do
out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH $
S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files
pure ["-optP-include", "-optP" <> toFilePath out]
writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String]
writeGhciScript outputDirectory script = do
scriptPath <- liftIO $ writeHashedFile outputDirectory relFileGhciScript $
LBS.toStrict $ scriptToLazyByteString script
let scriptFilePath = toFilePath scriptPath
setScriptPerms scriptFilePath
pure ["-ghci-script=" <> scriptFilePath]
writeHashedFile ::
Path Abs Dir
-> Path Rel File
-> ByteString
-> IO (Path Abs File)
writeHashedFile outputDirectory relFile contents = do
relSha <- shaPathForBytes contents
let outDir = outputDirectory </> relSha
outFile = outDir </> relFile
alreadyExists <- doesFileExist outFile
unless alreadyExists $ do
ensureDir outDir
writeBinaryFileAtomic outFile $ byteString contents
pure outFile
renderScript ::
Bool
-> [GhciPkgInfo]
-> Maybe (Path Abs File)
-> Bool
-> [Path Abs File]
-> GhciScript
renderScript isIntero pkgs mainFile onlyMain extraFiles = do
let cdPhase = case (isIntero, pkgs) of
-- If only loading one package, set the cwd properly.
-- Otherwise don't try. See
-- https://github.com/commercialhaskell/stack/issues/3309
(True, [pkg]) -> cmdCdGhc (ghciPkgDir pkg)
_ -> mempty
addPhase = cmdAdd $ S.fromList (map Left allModules ++ addMain)
addMain = case mainFile of
Just path -> [Right path]
_ -> []
modulePhase = cmdModule $ S.fromList allModules
allModules = nubOrd $ concatMap (M.keys . ghciPkgModules) pkgs
case getFileTargets pkgs <> extraFiles of
[] ->
if onlyMain
then cdPhase <> if isJust mainFile then cmdAdd (S.fromList addMain) else mempty
else cdPhase <> addPhase <> modulePhase
fileTargets -> cmdAdd (S.fromList (map Right fileTargets))
-- Hacky check if module / main phase should be omitted. This should be
-- improved if / when we have a better per-component load.
getFileTargets :: [GhciPkgInfo] -> [Path Abs File]
getFileTargets = concatMap (concat . maybeToList . ghciPkgTargetFiles)
-- | Figure out the main-is file to load based on the targets. Asks the
-- user for input if there is more than one candidate main-is file.
figureOutMainFile ::
(HasRunner env, HasTerm env)
=> BuildOpts
-> Maybe (Map PackageName Target)
-> [(PackageName, (Path Abs File, Target))]
-> [GhciPkgInfo]
-> RIO env (Maybe (Path Abs File))
figureOutMainFile bopts mainIsTargets targets0 packages =
case candidates of
[] -> pure Nothing
[c@(_,_,fp)] -> do
prettyInfo $
fillSep
[ "Using"
, style Current "main"
, "module:"
]
<> line
<> renderCandidate c
<> line
pure (Just fp)
candidate:_ -> do
prettyWarn $
fillSep
[ "The"
, style Current "main"
, flow "module to load is ambiguous. Candidates are:"
]
<> line
<> mconcat (L.intersperse line (map renderCandidate candidates))
<> blankLine
<> flow "You can specify which one to pick by:"
<> line
<> bulletedList
[ fillSep
[ flow "Specifying targets to"
, style Shell (flow "stack ghci")
, "e.g."
, style Shell ( fillSep
[ flow "stack ghci"
, sampleTargetArg candidate
]
) <> "."
]
, fillSep
[ flow "Specifying what the"
, style Current "main"
, flow "is e.g."
, style Shell ( fillSep
[ flow "stack ghci"
, sampleMainIsArg candidate
]
) <> "."
]
, flow
$ "Choosing from the candidate above [1.."
<> show (length candidates)
<> "]."
]
<> line
liftIO userOption
where
targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0)
mainIsTargets
candidates = do
pkg <- packages
case M.lookup (ghciPkgName pkg) targets of
Nothing -> []
Just target -> do
(component,mains) <-
M.toList $
M.filterWithKey (\k _ -> k `S.member` wantedComponents)
(ghciPkgMainIs pkg)
main <- mains
pure (ghciPkgName pkg, component, main)
where
wantedComponents =
wantedPackageComponents bopts target (ghciPkgPackage pkg)
renderCandidate c@(pkgName, namedComponent, mainIs) =
let candidateIndex =
fromString . show . (+1) . fromMaybe 0 . L.elemIndex c
pkgNameText = fromString $ packageNameString pkgName
in hang 4
$ fill 4 ( candidateIndex candidates <> ".")
<> fillSep
[ "Package"
, style Current pkgNameText <> ","
, "component"
-- This is the format that can be directly copy-pasted as
-- an argument to `stack ghci`.
, style
PkgComponent
( pkgNameText
<> ":"
<> renderComp namedComponent
)
<> ","
, "with"
, style Shell "main-is"
, "file:"
, pretty mainIs <> "."
]
candidateIndices = take (length candidates) [1 :: Int ..]
userOption = do
option <- prompt "Specify main module to use (press enter to load none): "
let selected = fromMaybe
((+1) $ length candidateIndices)
(readMaybe (T.unpack option) :: Maybe Int)
case L.elemIndex selected candidateIndices of
Nothing -> do
putStrLn
"Not loading any main modules, as no valid module selected"
putStrLn ""
pure Nothing
Just op -> do
let (_,_,fp) = candidates L.!! op
putStrLn
("Loading main module from candidate " <>
show (op + 1) <> ", --main-is " <>
toFilePath fp)
putStrLn ""
pure $ Just fp
renderComp c =
case c of
CLib -> "lib"
CInternalLib name -> "internal-lib:" <> fromString (T.unpack name)
CExe name -> "exe:" <> fromString (T.unpack name)
CTest name -> "test:" <> fromString ( T.unpack name)
CBench name -> "bench:" <> fromString (T.unpack name)
sampleTargetArg (pkg, comp, _) =
fromString (packageNameString pkg)
<> ":"
<> renderComp comp
sampleMainIsArg (pkg, comp, _) =
fillSep
[ "--main-is"
, fromString (packageNameString pkg) <> ":" <> renderComp comp
]
loadGhciPkgDescs ::
HasEnvConfig env
=> BuildOptsCLI
-> [(PackageName, (Path Abs File, Target))]
-> RIO env [GhciPkgDesc]
loadGhciPkgDescs buildOptsCLI localTargets =
forM localTargets $ \(name, (cabalfp, target)) ->
loadGhciPkgDesc buildOptsCLI name cabalfp target
-- | Load package description information for a ghci target.
loadGhciPkgDesc ::
HasEnvConfig env
=> BuildOptsCLI
-> PackageName
-> Path Abs File
-> Target
-> RIO env GhciPkgDesc
loadGhciPkgDesc buildOptsCLI name cabalfp target = do
econfig <- view envConfigL
compilerVersion <- view actualCompilerVersionL
let SourceMap{..} = envConfigSourceMap econfig
-- Currently this source map is being build with
-- the default targets
sourceMapGhcOptions = fromMaybe [] $
(cpGhcOptions . ppCommon <$> M.lookup name smProject)
<|>
(cpGhcOptions . dpCommon <$> M.lookup name smDeps)
sourceMapCabalConfigOpts = fromMaybe [] $
(cpCabalConfigOpts . ppCommon <$> M.lookup name smProject)
<|>
(cpCabalConfigOpts . dpCommon <$> M.lookup name smDeps)
sourceMapFlags =
maybe mempty (cpFlags . ppCommon) $ M.lookup name smProject
config = PackageConfig
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = True
, packageConfigFlags =
getLocalFlags buildOptsCLI name `M.union` sourceMapFlags
, packageConfigGhcOptions = sourceMapGhcOptions
, packageConfigCabalConfigOpts = sourceMapCabalConfigOpts
, packageConfigCompilerVersion = compilerVersion
, packageConfigPlatform = view platformL econfig
}
-- TODO we've already parsed this information, otherwise we
-- wouldn't have figured out the cabalfp already. In the future:
-- retain that GenericPackageDescription in the relevant data
-- structures to avoid reparsing.
(gpdio, _name, _cabalfp) <-
loadCabalFilePath (Just stackProgName') (parent cabalfp)
gpkgdesc <- liftIO $ gpdio YesPrintWarnings
-- Source the package's *.buildinfo file created by configure if any. See
-- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters
buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo")
hasDotBuildinfo <- doesFileExist (parent cabalfp </> buildinfofp)
let mbuildinfofp
| hasDotBuildinfo = Just (parent cabalfp </> buildinfofp)
| otherwise = Nothing
mbuildinfo <- forM mbuildinfofp readDotBuildinfo
let pdp = resolvePackageDescription config gpkgdesc
pkg =
packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $
maybe
pdp
(\bi ->
let PackageDescriptionPair x y = pdp
in PackageDescriptionPair
(C.updatePackageDescription bi x)
(C.updatePackageDescription bi y))
mbuildinfo
pure GhciPkgDesc
{ ghciDescPkg = pkg
, ghciDescCabalFp = cabalfp
, ghciDescTarget = target
}
getGhciPkgInfos ::
HasEnvConfig env
=> InstallMap
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> [GhciPkgDesc]
-> RIO env [GhciPkgInfo]
getGhciPkgInfos installMap addPkgs mfileTargets localTargets = do
(installedMap, _, _, _) <- getInstalled installMap
let localLibs =
[ packageName (ghciDescPkg desc)
| desc <- localTargets
, hasLocalComp isCLib (ghciDescTarget desc)
]
forM localTargets $ \pkgDesc ->
makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc
-- | Make information necessary to load the given package in GHCi.
makeGhciPkgInfo ::
HasEnvConfig env
=> InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File])
-> GhciPkgDesc
-> RIO env GhciPkgInfo
makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do
bopts <- view buildOptsL
let pkg = ghciDescPkg pkgDesc
cabalfp = ghciDescCabalFp pkgDesc
target = ghciDescTarget pkgDesc
name = packageName pkg
(mods,files,opts) <- getPackageOpts (packageOpts pkg) installMap installedMap locals addPkgs cabalfp
let filteredOpts = filterWanted opts
filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted)
allWanted = wantedPackageComponents bopts target pkg
pure GhciPkgInfo
{ ghciPkgName = name
, ghciPkgOpts = M.toList filteredOpts
, ghciPkgDir = parent cabalfp
, ghciPkgModules = unionModuleMaps $
map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp)
(M.toList (filterWanted mods))
, ghciPkgMainIs = M.map (mapMaybe dotCabalMainPath) files
, ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files)))
, ghciPkgTargetFiles = mfileTargets >>= M.lookup name
, ghciPkgPackage = pkg
}
-- NOTE: this should make the same choices as the components code in
-- 'loadLocalPackage'. Unfortunately for now we reiterate this logic
-- (differently).
wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent
wantedPackageComponents _ (TargetComps cs) _ = cs
wantedPackageComponents bopts (TargetAll PTProject) pkg = S.fromList $
(case packageLibraries pkg of
NoLibraries -> []
HasLibraries names -> CLib : map CInternalLib (S.toList names)) ++
map CExe (S.toList (packageExes pkg)) <>
map CInternalLib (S.toList $ packageInternalLibraries pkg) <>
(if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <>
(if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else [])
wantedPackageComponents _ _ _ = S.empty
checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForIssues pkgs =
when (length pkgs > 1) $ do
-- Cabal flag issues could arise only when there are at least 2 packages
unless (null cabalFlagIssues) $ do
prettyWarn $
flow "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."
<> blankLine
<> mconcat (L.intersperse blankLine cabalFlagIssues)
<> blankLine
<> flow "To resolve, remove the flag(s) from the Cabal file(s) and \
\instead put them at the top of the Haskell files."
<> blankLine
prettyWarnL
[ flow "It isn't yet possible to load multiple packages into GHCi in \
\all cases. For further information, see"
, style Url "https://ghc.haskell.org/trac/ghc/ticket/10827" <> "."
]
where
cabalFlagIssues = concatMap mixedFlag
[ ( "-XNoImplicitPrelude"
, [ flow "-XNoImplicitPrelude will be used, but GHCi will likely fail to \
\build things which depend on the implicit prelude."
]
)
, ( "-XCPP"
, [ flow "-XCPP will be used, but it can cause issues with multiline \
\strings. For further information, see"
, style Url "https://downloads.haskell.org/~ghc/7.10.2/docs/html/users_guide/options-phases.html#cpp-string-gaps" <> "."
]
)
, ( "-XNoTraditionalRecordSyntax"
, [ flow "-XNoTraditionalRecordSyntax will be used, but it break modules \
\which use record syntax."
]
)
, ( "-XTemplateHaskell"
, [ flow "-XTemplateHaskell will be used, but it may cause compilation \
\issues due to different parsing of '$' when there's no space \
\after it."
]
)
, ( "-XQuasiQuotes"
, [ flow "-XQuasiQuotes will be used, but it may cause parse failures \
\due to a different meaning for list comprehension syntax like \
\[x| ... ]"
]
)
, ( "-XSafe"
, [ flow "-XSafe will be used, but it will fail to compile unsafe \
\modules."
]
)
, ( "-XArrows"
, [ flow "-XArrows will be used, but it will cause non-arrow usages of \
\proc, (-<), (-<<) to fail"
]
)
, ( "-XOverloadedStrings"
, [ flow "-XOverloadedStrings will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( "-XOverloadedLists"
, [ flow "-XOverloadedLists will be used, but it can cause type \
\ambiguity in code not usually compiled with it."
]
)
, ( "-XMonoLocalBinds"
, [ flow "-XMonoLocalBinds will be used, but it can cause type errors in \
\code which expects generalized local bindings." ]
)
, ( "-XTypeFamilies"
, [ flow "-XTypeFamilies will be used, but it implies -XMonoLocalBinds, \
\and so can cause type errors in code which expects generalized \
\local bindings." ]
)
, ( "-XGADTs"
, [ flow "-XGADTs will be used, but it implies -XMonoLocalBinds, and so \
\can cause type errors in code which expects generalized local \
\bindings." ]
)
, ( "-XNewQualifiedOperators"
, [ flow "-XNewQualifiedOperators will be used, but this will break \
\usages of the old qualified operator syntax." ]
)
]
mixedFlag (flag, msgs) =
let x = partitionComps (== flag) in
[ fillSep $ msgs ++ showWhich x | mixedSettings x ]
mixedSettings (xs, ys) = xs /= [] && ys /= []
showWhich (haveIt, don'tHaveIt) =
[ flow "It is specified for:" ]
<> mkNarrativeList (Just PkgComponent) False
(map (fromString . T.unpack . renderPkgComponent) haveIt :: [StyleDoc])
<> [ flow "But not for:" ]
<> mkNarrativeList (Just PkgComponent) False
(map (fromString . T.unpack . renderPkgComponent) don'tHaveIt :: [StyleDoc])
partitionComps f = (map fst xs, map fst ys)
where
(xs, ys) = L.partition (any f . snd) compsWithOpts
compsWithOpts = map (\(k, bio) ->
(k, bioOneWordOpts bio ++ bioOpts bio)) compsWithBios
compsWithBios =
[ ((ghciPkgName pkg, c), bio)
| pkg <- pkgs
, (c, bio) <- ghciPkgOpts pkg
]
-- TODO: Should this also tell the user the filepaths, not just the
-- module name?
checkForDuplicateModules :: HasTerm env => [GhciPkgInfo] -> RIO env ()
checkForDuplicateModules pkgs =
unless (null duplicates) $
prettyWarn $
flow "Multiple files use the same module name:"
<> line
<> bulletedList (map prettyDuplicate duplicates)
<> line
-- MSS 2020-10-13 Disabling, may remove entirely in the future
-- See: https://github.com/commercialhaskell/stack/issues/5407#issuecomment-707339928
-- throwM LoadingDuplicateModules
where
duplicates ::
[(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))]
duplicates =
filter (\(_, mp) -> M.size mp > 1) $
M.toList $
unionModuleMaps (map ghciPkgModules pkgs)
prettyDuplicate ::
(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))
-> StyleDoc
prettyDuplicate (mn, mp) =
fillSep
[ style Error (pretty mn)
, flow "found at the following paths"
]
<> line
<> bulletedList (map fileDuplicate (M.toList mp))
fileDuplicate ::
(Path Abs File, Set (PackageName, NamedComponent)) -> StyleDoc
fileDuplicate (fp, comps) =
fillSep
[ pretty fp
, parens $
fillSep $ punctuate "," (map displayPkgComponent (S.toList comps))
]
targetWarnings ::
HasBuildConfig env
=> [(PackageName, (Path Abs File, Target))]
-> [PackageName]
-> Maybe (Map PackageName [Path Abs File], [Path Abs File])
-> RIO env ()
targetWarnings localTargets nonLocalTargets mfileTargets = do
unless (null nonLocalTargets) $
prettyWarnL
[ flow "Some targets"
, parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets
, flow "are not local packages, and so cannot be directly loaded."
, flow "In future versions of Stack, this might be supported - see"
, style Url "https://github.com/commercialhaskell/stack/issues/1441"
, "."
, flow "It can still be useful to specify these, as they will be passed to ghci via -package flags."
]
when (null localTargets && isNothing mfileTargets) $ do
smWanted <- view $ buildConfigL.to bcSMWanted
stackYaml <- view stackYamlL
prettyNote $ vsep
[ flow "No local targets specified, so a plain ghci will be started with no package hiding or package options."
, ""
, flow $ T.unpack $ utf8BuilderToText $
"You are using snapshot: " <>
display (smwSnapshotLocation smWanted)
, ""
, flow "If you want to use package hiding and options, then you can try one of the following:"
, ""
, bulletedList
[ fillSep
[ flow "If you want to start a different project configuration than" <+> pretty stackYaml <> ", then you can use"
, style Shell "stack init"
, flow "to create a new stack.yaml for the packages in the current directory."
, line
]
, flow "If you want to use the project configuration at" <+> pretty stackYaml <> ", then you can add to its 'packages' field."
]
, ""
]
-- Adds in intermediate dependencies between ghci targets. Note that it
-- will return a Lib component for these intermediate dependencies even
-- if they don't have a library (but that's fine for the usage within
-- this module).
--
-- If 'True' is passed for loadAllDeps, this loads all local deps, even
-- if they aren't intermediate.
getExtraLoadDeps ::
Bool
-> Map PackageName LocalPackage
-> [(PackageName, (Path Abs File, Target))]
-> [(PackageName, (Path Abs File, Target))]
getExtraLoadDeps loadAllDeps localMap targets =
M.toList $
(\mp -> foldl' (flip M.delete) mp (map fst targets)) $
M.mapMaybe id $
execState (mapM_ (mapM_ go . getDeps . fst) targets)
(M.fromList (map (second Just) targets))
where
getDeps :: PackageName -> [PackageName]
getDeps name =
case M.lookup name localMap of
Just lp -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local?
_ -> []
go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool
go name = do
cache <- get
case (M.lookup name cache, M.lookup name localMap) of
(Just (Just _), _) -> pure True
(Just Nothing, _) | not loadAllDeps -> pure False
(_, Just lp) -> do
let deps = M.keys (packageDeps (lpPackage lp))
shouldLoad <- or <$> mapM go deps
if shouldLoad
then do
modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib))))
pure True
else do
modify (M.insert name Nothing)
pure False
(_, _) -> pure False
unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
unionTargets = M.unionWith $ \l r -> case (l, r) of
(TargetAll PTDependency, _) -> r
(TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr)
(TargetComps _, TargetAll PTProject) -> TargetAll PTProject
(TargetComps _, _) -> l
(TargetAll PTProject, _) -> TargetAll PTProject
hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool
hasLocalComp p t = case t of
TargetComps s -> any p (S.toList s)
TargetAll PTProject -> True
_ -> False
-- | Run a command and grab the first line of stdout, dropping
-- stderr's contexts completely.
runGrabFirstLine ::
(HasProcessContext env, HasLogFunc env)
=> String
-> [String]
-> RIO env String
runGrabFirstLine cmd0 args =
proc cmd0 args $ \pc -> do
(out, _err) <- readProcess_ pc
pure
$ TL.unpack
$ TL.filter (/= '\r')
$ TL.concat
$ take 1
$ TL.lines
$ TLE.decodeUtf8With lenientDecode out