Commit e08974e8 authored by Zejun Wu's avatar Zejun Wu Committed by Ben Gamari

Introduce GhciMonad and generalize types of functions in GHCi.UI

Summary:
Introduce `GhciMonad`, which is bascially `GhcMonad` + `HasGhciState`.
Generalize the commands and help functions defined in `GHCi.UI` so they
can be used as both `GHCi a` and `InputT GHCi a`.

The long term plan is to move reusable bits to ghci library and make it
easier to build a customized interactive ui which carries customized state
and provides customized commands.

Most changes are trivial in this diff by relaxing the type constraint or
add/remove lift as necessary. The non-trivial changes are:

* Change `HasGhciState` to `GhciMonad` and expose it.
* Implementation of `reifyGHCi`.

Test Plan:
  ./validate

Reviewers: simonmar, hvr, bgamari

Reviewed By: simonmar

Subscribers: rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5433
parent 1be81c50
......@@ -6,6 +6,7 @@
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
......@@ -534,7 +535,7 @@ specified at the command line.
The ghci config file has not yet been processed.
-}
resetLastErrorLocations :: GHCi ()
resetLastErrorLocations :: GhciMonad m => m ()
resetLastErrorLocations = do
st <- getGHCiState
liftIO $ writeIORef (lastErrorLocations st) []
......@@ -737,12 +738,12 @@ checkPerms file =
return ok
#endif
incrementLineNo :: InputT GHCi ()
incrementLineNo :: GhciMonad m => m ()
incrementLineNo = modifyGHCiState incLineNo
where
incLineNo st = st { line_number = line_number st + 1 }
fileLoop :: Handle -> InputT GHCi (Maybe String)
fileLoop :: GhciMonad m => Handle -> m (Maybe String)
fileLoop hdl = do
l <- liftIO $ tryIO $ hGetLine hdl
case l of
......@@ -778,7 +779,7 @@ getUserName = do
getLoginName
#endif
getInfoForPrompt :: GHCi (SDoc, [String], Int)
getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)
getInfoForPrompt = do
st <- getGHCiState
imports <- GHC.getContext
......@@ -914,7 +915,7 @@ mkPrompt = do
return (showSDoc dflags prompt_doc)
queryQueue :: GHCi (Maybe String)
queryQueue :: GhciMonad m => m (Maybe String)
queryQueue = do
st <- getGHCiState
case cmdqueue st of
......@@ -923,7 +924,7 @@ queryQueue = do
return (Just c)
-- Reconfigurable pretty-printing Ticket #5461
installInteractivePrint :: Maybe String -> Bool -> GHCi ()
installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()
installInteractivePrint Nothing _ = return ()
installInteractivePrint (Just ipFun) exprmode = do
ok <- trySuccess $ do
......@@ -1078,8 +1079,8 @@ runOneCommand eh gCmd = do
-- #4316
-- lex the input. If there is an unclosed layout context, request input
checkInputForLayout :: String -> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe String)
checkInputForLayout
:: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)
checkInputForLayout stmt getStmt = do
dflags' <- getDynFlags
let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule
......@@ -1116,7 +1117,7 @@ checkInputForLayout stmt getStmt = do
then Lexer.activeContext
else Lexer.lexer False return >> goToEnd
enqueueCommands :: [String] -> GHCi ()
enqueueCommands :: GhciMonad m => [String] -> m ()
enqueueCommands cmds = do
-- make sure we force any exceptions in the commands while we're
-- still inside the exception handler, otherwise bad things will
......@@ -1126,7 +1127,7 @@ enqueueCommands cmds = do
-- | Entry point to execute some haskell code from user.
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
runStmt input step = do
dflags <- GHC.getInteractiveDynFlags
-- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
......@@ -1171,7 +1172,7 @@ runStmt input step = do
addImportToContext input
return (Just exec_complete)
run_stmt :: GhciLStmt GhcPs -> GHCi (Maybe GHC.ExecResult)
run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)
run_stmt stmt = do
m_result <- GhciMonad.runStmt stmt input step
case m_result of
......@@ -1192,7 +1193,7 @@ runStmt input step = do
--
-- Instead of dealing with all these problems individually here we fix this
-- mess by just treating `x = y` as `let x = y`.
run_decls :: [LHsDecl GhcPs] -> GHCi (Maybe GHC.ExecResult)
run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)
-- Only turn `FunBind` and `VarBind` into statements, other bindings
-- (e.g. `PatBind`) need to stay as decls.
run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)
......@@ -1216,7 +1217,8 @@ runStmt input step = do
in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult
afterRunStmt :: GhciMonad m
=> (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
afterRunStmt step_here run_result = do
resumes <- GHC.getResumeContext
case run_result of
......@@ -1260,8 +1262,8 @@ runAllocs m = do
GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
_ -> Nothing
toBreakIdAndLocation ::
Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
toBreakIdAndLocation :: GhciMonad m
=> Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))
toBreakIdAndLocation Nothing = return Nothing
toBreakIdAndLocation (Just inf) = do
let md = GHC.breakInfo_module inf
......@@ -1271,7 +1273,7 @@ toBreakIdAndLocation (Just inf) = do
breakModule loc == md,
breakTick loc == nm ]
printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()
printStoppedAtBreakInfo res names = do
printForUser $ pprStopped res
-- printTypeOfNames session names
......@@ -1280,7 +1282,7 @@ printStoppedAtBreakInfo res names = do
docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
printForUserPartWay $ vcat docs
printTypeOfNames :: [Name] -> GHCi ()
printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()
printTypeOfNames names
= mapM_ (printTypeOfName ) $ sortBy compareNames names
......@@ -1288,7 +1290,7 @@ compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
where compareWith n = (getOccString n, getSrcSpan n)
printTypeOfName :: Name -> GHCi ()
printTypeOfName :: GHC.GhcMonad m => Name -> m ()
printTypeOfName n
= do maybe_tything <- GHC.lookupName n
case maybe_tything of
......@@ -1303,7 +1305,7 @@ specialCommand :: String -> InputT GHCi Bool
specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
specialCommand str = do
let (cmd,rest) = break isSpace str
maybe_cmd <- lift $ lookupCommand cmd
maybe_cmd <- lookupCommand cmd
htxt <- short_help <$> getGHCiState
case maybe_cmd of
GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)
......@@ -1316,10 +1318,10 @@ specialCommand str = do
++ htxt)
return False
shellEscape :: String -> GHCi Bool
shellEscape :: MonadIO m => String -> m Bool
shellEscape str = liftIO (system str >> return False)
lookupCommand :: String -> GHCi (MaybeCommand)
lookupCommand :: GhciMonad m => String -> m (MaybeCommand)
lookupCommand "" = do
st <- getGHCiState
case last_command st of
......@@ -1332,7 +1334,7 @@ lookupCommand str = do
Just c -> GotCommand c
Nothing -> BadCommand
lookupCommand' :: String -> GHCi (Maybe Command)
lookupCommand' :: GhciMonad m => String -> m (Maybe Command)
lookupCommand' ":" = return Nothing
lookupCommand' str' = do
macros <- ghci_macros <$> getGHCiState
......@@ -1359,7 +1361,7 @@ lookupCommand' str' = do
builtinPfxMatch <|>
lookupPrefix str xcmds
getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan = do
resumes <- GHC.getResumeContext
case resumes of
......@@ -1373,7 +1375,7 @@ getCurrentBreakSpan = do
pan <- GHC.getHistorySpan hist
return (Just pan)
getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])
getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])
getCallStackAtCurrentBreakpoint = do
resumes <- GHC.getResumeContext
case resumes of
......@@ -1382,7 +1384,7 @@ getCallStackAtCurrentBreakpoint = do
hsc_env <- GHC.getSession
Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))
getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
getCurrentBreakModule = do
resumes <- GHC.getResumeContext
case resumes of
......@@ -1401,11 +1403,11 @@ getCurrentBreakModule = do
--
-----------------------------------------------------------------------------
noArgs :: GHCi () -> String -> GHCi ()
noArgs :: MonadIO m => m () -> String -> m ()
noArgs m "" = m
noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
withSandboxOnly :: String -> GHCi () -> GHCi ()
withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()
withSandboxOnly cmd this = do
dflags <- getDynFlags
if not (gopt Opt_GhciSandbox dflags)
......@@ -1416,7 +1418,7 @@ withSandboxOnly cmd this = do
-----------------------------------------------------------------------------
-- :help
help :: String -> GHCi ()
help :: GhciMonad m => String -> m ()
help _ = do
txt <- long_help `fmap` getGHCiState
liftIO $ putStr txt
......@@ -1424,7 +1426,7 @@ help _ = do
-----------------------------------------------------------------------------
-- :info
info :: Bool -> String -> InputT GHCi ()
info :: GHC.GhcMonad m => Bool -> String -> m ()
info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info allInfo s = handleSourceError GHC.printException $ do
unqual <- GHC.getPrintUnqual
......@@ -1467,7 +1469,7 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs)
-----------------------------------------------------------------------------
-- :main
runMain :: String -> GHCi ()
runMain :: GhciMonad m => String -> m ()
runMain s = case toArgs s of
Left err -> liftIO (hPutStrLn stderr err)
Right args ->
......@@ -1480,19 +1482,19 @@ runMain s = case toArgs s of
-----------------------------------------------------------------------------
-- :run
runRun :: String -> GHCi ()
runRun :: GhciMonad m => String -> m ()
runRun s = case toCmdArgs s of
Left err -> liftIO (hPutStrLn stderr err)
Right (cmd, args) -> doWithArgs args cmd
doWithArgs :: [String] -> String -> GHCi ()
doWithArgs :: GhciMonad m => [String] -> String -> m ()
doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
show args ++ " (" ++ cmd ++ ")"]
-----------------------------------------------------------------------------
-- :cd
changeDirectory :: String -> InputT GHCi ()
changeDirectory :: GhciMonad m => String -> m ()
changeDirectory "" = do
-- :cd on its own changes to the user's home directory
either_dir <- liftIO $ tryIO getHomeDirectory
......@@ -1505,7 +1507,7 @@ changeDirectory dir = do
liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
GHC.setTargets []
_ <- GHC.load LoadAllTargets
lift $ setContextAfterLoad False []
setContextAfterLoad False []
GHC.workingDirectoryChanged
dir' <- expandPath dir
liftIO $ setCurrentDirectory dir'
......@@ -1527,9 +1529,9 @@ trySuccess act =
-----------------------------------------------------------------------------
-- :edit
editFile :: String -> InputT GHCi ()
editFile :: GhciMonad m => String -> m ()
editFile str =
do file <- if null str then lift chooseEditFile else expandPath str
do file <- if null str then chooseEditFile else expandPath str
st <- getGHCiState
errs <- liftIO $ readIORef $ lastErrorLocations st
let cmd = editor st
......@@ -1559,7 +1561,7 @@ editFile str =
-- XXX: if we could figure out the list of errors that occured during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHCi String
chooseEditFile :: GHC.GhcMonad m => m String
chooseEditFile =
do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
......@@ -1586,7 +1588,7 @@ chooseEditFile =
-----------------------------------------------------------------------------
-- :def
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
defineMacro _ (':':_) =
liftIO $ putStrLn "macro name cannot start with a colon"
defineMacro overwrite s = do
......@@ -1628,7 +1630,11 @@ defineMacro overwrite s = do
let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
in s { ghci_macros = newCmd : filtered }
runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool
runMacro
:: GhciMonad m
=> GHC.ForeignHValue -- String -> IO String
-> String
-> m Bool
runMacro fun s = do
hsc_env <- GHC.getSession
str <- liftIO $ evalStringToIOString hsc_env fun s
......@@ -1639,7 +1645,7 @@ runMacro fun s = do
-----------------------------------------------------------------------------
-- :undef
undefineMacro :: String -> GHCi ()
undefineMacro :: GhciMonad m => String -> m ()
undefineMacro str = mapM_ undef (words str)
where undef macro_name = do
cmds <- ghci_macros <$> getGHCiState
......@@ -1656,7 +1662,7 @@ undefineMacro str = mapM_ undef (words str)
-----------------------------------------------------------------------------
-- :cmd
cmdCmd :: String -> GHCi ()
cmdCmd :: GhciMonad m => String -> m ()
cmdCmd str = handleSourceError GHC.printException $ do
step <- getGhciStepIO
expr <- GHC.parseExpr str
......@@ -1670,7 +1676,7 @@ cmdCmd str = handleSourceError GHC.printException $ do
-- | Generate a typed ghciStepIO expression
-- @ghciStepIO :: Ty String -> IO String@.
getGhciStepIO :: GHCi (LHsExpr GhcPs)
getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO = do
ghciTyConName <- GHC.getGHCiMonad
let stringTy = nlHsTyVar stringTy_RDR
......@@ -1683,7 +1689,7 @@ getGhciStepIO = do
-----------------------------------------------------------------------------
-- :check
checkModule :: String -> InputT GHCi ()
checkModule :: GhciMonad m => String -> m ()
checkModule m = do
let modl = GHC.mkModuleName m
ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
......@@ -1705,7 +1711,7 @@ checkModule m = do
-----------------------------------------------------------------------------
-- :doc
docCmd :: String -> InputT GHCi ()
docCmd :: GHC.GhcMonad m => String -> m ()
docCmd "" =
throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
docCmd s = do
......@@ -1740,7 +1746,7 @@ handleGetDocsFailure no_docs = do
-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
-- '-fdefer-type-errors' again if it has not been set before.
wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a
wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a
wrapDeferTypeErrors load =
gbracket
(do
......@@ -1752,19 +1758,19 @@ wrapDeferTypeErrors load =
(\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
(\_ -> load)
loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
loadModule fs = do
(_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)
either (liftIO . Exception.throwIO) return result
-- | @:load@ command
loadModule_ :: [FilePath] -> InputT GHCi ()
loadModule_ :: GhciMonad m => [FilePath] -> m ()
loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))
loadModuleDefer :: [FilePath] -> InputT GHCi ()
loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
loadModuleDefer = wrapDeferTypeErrors . loadModule_
loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag
loadModule' files = do
let (filenames, phases) = unzip files
exp_filenames <- mapM expandPath filenames
......@@ -1787,7 +1793,7 @@ loadModule' files = do
-- unload first
_ <- GHC.abandonAll
lift discardActiveBreakPoints
discardActiveBreakPoints
GHC.setTargets []
_ <- GHC.load LoadAllTargets
......@@ -1798,9 +1804,9 @@ loadModule' files = do
return success
-- | @:add@ command
addModule :: [FilePath] -> InputT GHCi ()
addModule :: GhciMonad m => [FilePath] -> m ()
addModule files = do
lift revertCAFs -- always revert CAFs on load/add.
revertCAFs -- always revert CAFs on load/add.
files' <- mapM expandPath files
targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
targets' <- filterM checkTarget targets
......@@ -1810,11 +1816,11 @@ addModule files = do
_ <- doLoadAndCollectInfo False LoadAllTargets
return ()
where
checkTarget :: Target -> InputT GHCi Bool
checkTarget :: GHC.GhcMonad m => Target -> m Bool
checkTarget (Target (TargetModule m) _ _) = checkTargetModule m
checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f
checkTargetModule :: ModuleName -> InputT GHCi Bool
checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool
checkTargetModule m = do
hsc_env <- GHC.getSession
result <- liftIO $
......@@ -1831,7 +1837,7 @@ addModule files = do
return exists
-- | @:unadd@ command
unAddModule :: [FilePath] -> InputT GHCi ()
unAddModule :: GhciMonad m => [FilePath] -> m ()
unAddModule files = do
files' <- mapM expandPath files
targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
......@@ -1840,13 +1846,13 @@ unAddModule files = do
return ()
-- | @:reload@ command
reloadModule :: String -> InputT GHCi ()
reloadModule :: GhciMonad m => String -> m ()
reloadModule m = void $ doLoadAndCollectInfo True loadTargets
where
loadTargets | null m = LoadAllTargets
| otherwise = LoadUpTo (GHC.mkModuleName m)
reloadModuleDefer :: String -> InputT GHCi ()
reloadModuleDefer :: GhciMonad m => String -> m ()
reloadModuleDefer = wrapDeferTypeErrors . reloadModule
-- | Load/compile targets and (optionally) collect module-info
......@@ -1861,9 +1867,9 @@ reloadModuleDefer = wrapDeferTypeErrors . reloadModule
-- since those commands are designed to be used by editors and
-- tooling, it's useless to collect this data for normal GHCi
-- sessions.
doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo retain_context howmuch = do
doCollectInfo <- lift (isOptionSet CollectInfo)
doCollectInfo <- isOptionSet CollectInfo
doLoad retain_context howmuch >>= \case
Succeeded | doCollectInfo -> do
......@@ -1875,13 +1881,13 @@ doLoadAndCollectInfo retain_context howmuch = do
return Succeeded
flag -> return flag
doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag
doLoad retain_context howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
lift discardActiveBreakPoints
discardActiveBreakPoints
lift resetLastErrorLocations
resetLastErrorLocations
-- Enable buffering stdout and stderr as we're compiling. Keeping these
-- handles unbuffered will just slow the compilation down, especially when
-- compiling in parallel.
......@@ -1895,17 +1901,19 @@ doLoad retain_context howmuch = do
return ok
afterLoad :: SuccessFlag
-> Bool -- keep the remembered_ctx, as far as possible (:reload)
-> InputT GHCi ()
afterLoad
:: GhciMonad m
=> SuccessFlag
-> Bool -- keep the remembered_ctx, as far as possible (:reload)
-> m ()
afterLoad ok retain_context = do
lift revertCAFs -- always revert CAFs on load.
lift discardTickArrays
revertCAFs -- always revert CAFs on load.
discardTickArrays
loaded_mods <- getLoadedModules
modulesLoadedMsg ok loaded_mods
lift $ setContextAfterLoad retain_context loaded_mods
setContextAfterLoad retain_context loaded_mods
setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()
setContextAfterLoad keep_ctxt [] = do
setContextKeepingPackageModules keep_ctxt []
setContextAfterLoad keep_ctxt ms = do
......@@ -1945,11 +1953,11 @@ setContextAfterLoad keep_ctxt ms = do
-- | Keep any package modules (except Prelude) when changing the context.
setContextKeepingPackageModules
:: Bool -- True <=> keep all of remembered_ctx
-- False <=> just keep package imports
-> [InteractiveImport] -- new context
-> GHCi ()
:: GhciMonad m
=> Bool -- True <=> keep all of remembered_ctx
-- False <=> just keep package imports
-> [InteractiveImport] -- new context
-> m ()
setContextKeepingPackageModules keep_ctx trans_ctx = do
st <- getGHCiState
......@@ -1964,10 +1972,11 @@ setContextKeepingPackageModules keep_ctx trans_ctx = do
-- imports so only imports from external packages are preserved. ('IIModule'
-- counts as a home package import, because we are only able to bring a
-- full top-level into scope when the source is available.)
keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
keepPackageImports
:: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]
keepPackageImports = filterM is_pkg_import
where
is_pkg_import :: InteractiveImport -> GHCi Bool
is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
is_pkg_import (IIModule _) = return False
is_pkg_import (IIDecl d)
= do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
......@@ -1978,7 +1987,7 @@ keepPackageImports = filterM is_pkg_import
mod_name = unLoc (ideclName d)
modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()
modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
modulesLoadedMsg ok mods = do
dflags <- getDynFlags
unqual <- GHC.getPrintUnqual
......@@ -2028,7 +2037,7 @@ exceptT = ExceptT . pure
-----------------------------------------------------------------------------
-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr :: GHC.GhcMonad m => String -> m ()
typeOfExpr str = handleSourceError GHC.printException $ do
let (mode, expr_str) = case break isSpace str of
("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)
......@@ -2040,10 +2049,10 @@ typeOfExpr str = handleSourceError GHC.printException $ do
-----------------------------------------------------------------------------
-- | @:type-at@ command
typeAtCmd :: String -> InputT GHCi ()
typeAtCmd :: GhciMonad m => String -> m ()
typeAtCmd str = runExceptGhcMonad $ do
(span',sample) <- exceptT $ parseSpanArg str
infos <- mod_infos <$> getGHCiState
infos <- lift $ mod_infos <$> getGHCiState
(info, ty) <- findType infos span' sample
lift $ printForUserModInfo (modinfoInfo info)
(sep [text sample,nest 2 (dcolon <+> ppr ty)])
......@@ -2051,29 +2060,29 @@ typeAtCmd str = runExceptGhcMonad $ do
-----------------------------------------------------------------------------
-- | @:uses@ command
usesCmd :: String -> InputT GHCi ()
usesCmd :: GhciMonad m => String -> m ()
usesCmd str = runExceptGhcMonad $ do
(span',sample) <- exceptT $ parseSpanArg str
infos <- mod_infos <$> getGHCiState
infos <- lift $ mod_infos <$> getGHCiState
uses <- findNameUses infos span' sample
forM_ uses (liftIO . putStrLn . showSrcSpan)
-----------------------------------------------------------------------------
-- | @:loc-at@ command
locAtCmd :: String -> InputT GHCi ()
locAtCmd :: GhciMonad m => String -> m ()
locAtCmd str = runExceptGhcMonad $ do
(span',sample) <- exceptT $ parseSpanArg str
infos <- mod_infos <$> getGHCiState
infos <- lift $ mod_infos <$> getGHCiState
(_,_,sp) <- findLoc infos span' sample
liftIO . putStrLn . showSrcSpan $ sp
-----------------------------------------------------------------------------
-- | @:all-types@ command
allTypesCmd :: String -> InputT GHCi ()
allTypesCmd :: GhciMonad m => String -> m ()
allTypesCmd _ = runExceptGhcMonad $ do
infos <- mod_infos <$> getGHCiState
infos <- lift $ mod_infos <$> getGHCiState
forM_ (M.elems infos) $ \mi ->
forM_ (modinfoSpans mi) (lift . printSpan)
where
......@@ -2159,7 +2168,7 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
-----------------------------------------------------------------------------
-- | @:kind@ command
kindOfType :: Bool -> String -> InputT GHCi ()
kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()
kindOfType norm str = handleSourceError GHC.printException $ do
(ty, kind) <- GHC.typeKind norm str
printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
......@@ -2168,7 +2177,7 @@ kindOfType norm str = handleSourceError GHC.printException $ do
-----------------------------------------------------------------------------
-- :quit
quit :: String -> InputT GHCi Bool
quit :: Monad m => String -> m Bool
quit _ = return True
......@@ -2213,17 +2222,17 @@ runScript filename = do
-- Displaying Safe Haskell properties of a module
isSafeCmd :: String -> InputT GHCi ()
isSafeCmd :: GHC.GhcMonad m => String -> m ()
isSafeCmd m =
case words m of
[s] | looksLikeModuleName s -> do
md <- lift $ lookupModule s
md <- lookupModule s
isSafeModule md
[] -> do md <- guessCurrentModule "issafe"
isSafeModule md
_ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
isSafeModule :: Module -> InputT GHCi ()
isSafeModule :: GHC.GhcMonad m => Module -> m ()
isSafeModule m = do
mb_mod_info <- GHC.getModuleInfo m
when (isNothing mb_mod_info)
......@@ -2270,20 +2279,20 @@ isSafeModule m = do
-- Browsing a module's contents
browseCmd :: Bool -> String -> InputT GHCi ()
browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()
browseCmd bang m =
case words m of
['*':s] | looksLikeModuleName s -> do
md <- lift $ wantInterpretedModule s
md <- wantInterpretedModule s
browseModule bang md False
[s] | looksLikeModuleName s -> do
md <- lift $ lookupModule s
md <- lookupModule s
browseModule bang md True
[] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
browseModule bang md True
_ -> throwGhcException (CmdLineError "syntax: :browse <module>")
guessCurrentModule :: String -> InputT GHCi Module
guessCurrentModule :: GHC.GhcMonad m => String -> m Module
-- Guess which module the user wants to browse. Pick
-- modules that are interpreted first. The most
-- recently-added module occurs last, it seems.
......@@ -2300,7 +2309,7 @@ guessCurrentModule cmd
-- with bang, show class methods and data constructors separately, and
-- indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()
browseModule bang modl exports_only = do
-- :browse reports qualifiers wrt current context
unqual <- GHC.getPrintUnqual
......@@ -2381,7 +2390,7 @@ browseModule bang modl exports_only = do
-- Setting the module context. For details on context handling see
-- "remembered_ctx" and "transient_ctx" in GhciMonad.
moduleCmd :: String -> GHCi ()
moduleCmd :: GhciMonad m => String -> m ()
moduleCmd str
| all sensible strs = cmd
| otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
......@@ -2410,16 +2419,16 @@ moduleCmd str
-- (c) :module <stuff>: setContext
-- (d) import <module>...: addImportToContext
addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext starred unstarred = restoreContextOnFailure $ do
addModulesToContext_ starred unstarred
addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ starred unstarred = do
mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
setGHCContextFromGHCiState
remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
remModulesFromContext starred unstarred = do
-- we do *not* call restoreContextOnFailure here. If the user
-- is trying to fix up a context that contains errors by removing
......@@ -2427,7 +2436,7 @@ remModulesFromContext starred unstarred = do
mapM_ rm (starred ++ unstarred)
setGHCContextFromGHCiState
where
rm :: ModuleName -> GHCi ()
rm :: GhciMonad m => ModuleName -> m ()