summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorZejun Wu <watashi@fb.com>2019-01-21 16:28:01 -0800
committerBen Gamari <ben@smart-cactus.org>2019-01-31 12:46:51 -0500
commite08974e81ccc84b5887d13cc4752fde9a78c51fb (patch)
tree0c2d12762972c39f29c25c650735bd5b3570dc38
parent1be81c50b51d0c9c651cbdd14bb7cf6884d011ff (diff)
downloadhaskell-e08974e81ccc84b5887d13cc4752fde9a78c51fb.tar.gz
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
-rw-r--r--ghc/GHCi/UI.hs403
-rw-r--r--ghc/GHCi/UI/Monad.hs81
2 files changed, 250 insertions, 234 deletions
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index abb3d78fae..5e26685a69 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -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 ()
rm str = do
m <- moduleName <$> lookupModuleName str
let filt = filter ((/=) m . iiModuleName)
@@ -2435,20 +2444,20 @@ remModulesFromContext starred unstarred = do
st { remembered_ctx = filt (remembered_ctx st)
, transient_ctx = filt (transient_ctx st) }
-setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
setContext starred unstarred = restoreContextOnFailure $ do
modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
-- delete the transient context
addModulesToContext_ starred unstarred
-addImportToContext :: String -> GHCi ()
+addImportToContext :: GhciMonad m => String -> m ()
addImportToContext str = restoreContextOnFailure $ do
idecl <- GHC.parseImportDecl str
addII (IIDecl idecl) -- #5836
setGHCContextFromGHCiState
-- Util used by addImportToContext and addModulesToContext
-addII :: InteractiveImport -> GHCi ()
+addII :: GhciMonad m => InteractiveImport -> m ()
addII iidecl = do
checkAdd iidecl
modifyGHCiState $ \st ->
@@ -2469,7 +2478,7 @@ addII iidecl = do
--
-- See #6007
--
-restoreContextOnFailure :: GHCi a -> GHCi a
+restoreContextOnFailure :: GhciMonad m => m a -> m a
restoreContextOnFailure do_this = do
st <- getGHCiState
let rc = remembered_ctx st; tc = transient_ctx st
@@ -2479,7 +2488,7 @@ restoreContextOnFailure do_this = do
-- -----------------------------------------------------------------------------
-- Validate a module that we want to add to the context
-checkAdd :: InteractiveImport -> GHCi ()
+checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()
checkAdd ii = do
dflags <- getDynFlags
let safe = safeLanguageOn dflags
@@ -2511,7 +2520,7 @@ checkAdd ii = do
-- override the implicit Prelude import you can say 'import Prelude ()'
-- at the prompt, just as in Haskell source.
--
-setGHCContextFromGHCiState :: GHCi ()
+setGHCContextFromGHCiState :: GhciMonad m => m ()
setGHCContextFromGHCiState = do
st <- getGHCiState
-- re-use checkAdd to check whether the module is valid. If the
@@ -2530,7 +2539,8 @@ setGHCContextFromGHCiState = do
GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls
-getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]
+getImplicitPreludeImports :: GhciMonad m
+ => [InteractiveImport] -> m [InteractiveImport]
getImplicitPreludeImports iidecls = do
dflags <- GHC.getInteractiveDynFlags
-- allow :seti to override -XNoImplicitPrelude
@@ -2626,7 +2636,7 @@ iiSubsumes _ _ = False
-- This is pretty fragile: most options won't work as expected. ToDo:
-- figure out which ones & disallow them.
-setCmd :: String -> GHCi ()
+setCmd :: GhciMonad m => String -> m ()
setCmd "" = showOptions False
setCmd "-a" = showOptions True
setCmd str
@@ -2657,7 +2667,7 @@ setCmd str
Left err -> liftIO (hPutStrLn stderr err)
Right wds -> setOptions wds
-setiCmd :: String -> GHCi ()
+setiCmd :: GhciMonad m => String -> m ()
setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
setiCmd str =
@@ -2665,7 +2675,7 @@ setiCmd str =
Left err -> liftIO (hPutStrLn stderr err)
Right wds -> newDynFlags True wds
-showOptions :: Bool -> GHCi ()
+showOptions :: GhciMonad m => Bool -> m ()
showOptions show_all
= do st <- getGHCiState
dflags <- getDynFlags
@@ -2716,8 +2726,8 @@ showDynFlags show_all dflags = do
, Opt_PrintEvldWithShow
]
-setArgs, setOptions :: [String] -> GHCi ()
-setProg, setEditor, setStop :: String -> GHCi ()
+setArgs, setOptions :: GhciMonad m => [String] -> m ()
+setProg, setEditor, setStop :: GhciMonad m => String -> m ()
setArgs args = do
st <- getGHCiState
@@ -2746,13 +2756,13 @@ setStop str@(c:_) | isDigit c
setGHCiState st{ breaks = new_breaks }
setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
-setPrompt :: PromptFunction -> GHCi ()
+setPrompt :: GhciMonad m => PromptFunction -> m ()
setPrompt v = modifyGHCiState (\st -> st {prompt = v})
-setPromptCont :: PromptFunction -> GHCi ()
+setPromptCont :: GhciMonad m => PromptFunction -> m ()
setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})
-setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()
+setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()
setPromptFunc fSetPrompt s = do
-- We explicitly annotate the type of the expression to ensure
-- that unsafeCoerce# is passed the exact type necessary rather
@@ -2766,7 +2776,8 @@ setPromptFunc fSetPrompt s = do
convertToPromptFunction func = (\mods line -> liftIO $
liftM text (func mods line))
-setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()
+setPromptString :: MonadIO m
+ => (PromptFunction -> m ()) -> String -> String -> m ()
setPromptString fSetPrompt value err = do
if null value
then liftIO $ hPutStrLn stderr $ err
@@ -2780,7 +2791,8 @@ setPromptString fSetPrompt value err = do
_ ->
setParsedPromptString fSetPrompt value
-setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()
+setParsedPromptString :: MonadIO m
+ => (PromptFunction -> m ()) -> String -> m ()
setParsedPromptString fSetPrompt s = do
case (checkPromptStringForErrors s) of
Just err ->
@@ -2795,7 +2807,7 @@ setOptions wds =
-- then, dynamic flags
when (not (null minus_opts)) $ newDynFlags False minus_opts
-newDynFlags :: Bool -> [String] -> GHCi ()
+newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
newDynFlags interactive_only minus_opts = do
let lopts = map noLoc minus_opts
@@ -2858,7 +2870,7 @@ newDynFlags interactive_only minus_opts = do
return ()
-unsetOptions :: String -> GHCi ()
+unsetOptions :: GhciMonad m => String -> m ()
unsetOptions str
= -- first, deal with the GHCi opts (+s, +t, etc.)
let opts = words str
@@ -2897,7 +2909,7 @@ isPlus :: String -> Either String String
isPlus ('+':opt) = Left opt
isPlus other = Right other
-setOpt, unsetOpt :: String -> GHCi ()
+setOpt, unsetOpt :: GhciMonad m => String -> m ()
setOpt str
= case strToGHCiOpt str of
@@ -2928,21 +2940,21 @@ optToStr CollectInfo = "c"
-- ---------------------------------------------------------------------------
-- :show
-showCmd :: String -> GHCi ()
+showCmd :: forall m. GhciMonad m => String -> m ()
showCmd "" = showOptions False
showCmd "-a" = showOptions True
showCmd str = do
st <- getGHCiState
dflags <- getDynFlags
- let lookupCmd :: String -> Maybe (GHCi ())
+ let lookupCmd :: String -> Maybe (m ())
lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
-- (show in help?, command name, action)
- action :: String -> GHCi () -> (Bool, String, GHCi ())
+ action :: String -> m () -> (Bool, String, m ())
action name m = (True, name, m)
- hidden :: String -> GHCi () -> (Bool, String, GHCi ())
+ hidden :: String -> m () -> (Bool, String, m ())
hidden name m = (False, name, m)
cmds =
@@ -2973,7 +2985,7 @@ showCmd str = do
$ hang (text ":show") 6
$ brackets (fsep $ punctuate (text " |") helpCmds)
-showiCmd :: String -> GHCi ()
+showiCmd :: GHC.GhcMonad m => String -> m ()
showiCmd str = do
case words str of
["languages"] -> showiLanguages -- backwards compat
@@ -2981,7 +2993,7 @@ showiCmd str = do
["lang"] -> showiLanguages -- useful abbreviation
_ -> throwGhcException (CmdLineError ("syntax: :showi language"))
-showImports :: GHCi ()
+showImports :: GhciMonad m => m ()
showImports = do
st <- getGHCiState
dflags <- getDynFlags
@@ -3004,7 +3016,7 @@ showImports = do
map show_prel prel_iidecls ++
map show_extra (extra_imports st))
-showModules :: GHCi ()
+showModules :: GHC.GhcMonad m => m ()
showModules = do
loaded_mods <- getLoadedModules
-- we want *loaded* modules only, see #1734
@@ -3016,7 +3028,7 @@ getLoadedModules = do
graph <- GHC.getModuleGraph
filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)
-showBindings :: GHCi ()
+showBindings :: GHC.GhcMonad m => m ()
showBindings = do
bindings <- GHC.getBindings
(insts, finsts) <- GHC.getInsts
@@ -3043,7 +3055,7 @@ showBindings = do
| otherwise = ppr fixity <+> ppr (GHC.getName thing)
-printTyThing :: TyThing -> GHCi ()
+printTyThing :: GHC.GhcMonad m => TyThing -> m ()
printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
{-
@@ -3069,12 +3081,12 @@ Note [What to show to users] in compiler/main/InteractiveEval.hs
-}
-showBkptTable :: GHCi ()
+showBkptTable :: GhciMonad m => m ()
showBkptTable = do
st <- getGHCiState
printForUser $ prettyLocations (breaks st)
-showContext :: GHCi ()
+showContext :: GHC.GhcMonad m => m ()
showContext = do
resumes <- GHC.getResumeContext
printForUser $ vcat (map pp_resume (reverse resumes))
@@ -3094,7 +3106,7 @@ pprStopped res =
where
mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
-showPackages :: GHCi ()
+showPackages :: GHC.GhcMonad m => m ()
showPackages = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
@@ -3102,7 +3114,7 @@ showPackages = do
text ("active package flags:"++if null pkg_flags then " none" else "") $$
nest 2 (vcat (map pprFlag pkg_flags))
-showPaths :: GHCi ()
+showPaths :: GHC.GhcMonad m => m ()
showPaths = do
dflags <- getDynFlags
liftIO $ do
@@ -3115,10 +3127,10 @@ showPaths = do
text ("module import search paths:"++if null ipaths then " none" else "") $$
nest 2 (vcat (map text ipaths))
-showLanguages :: GHCi ()
+showLanguages :: GHC.GhcMonad m => m ()
showLanguages = getDynFlags >>= liftIO . showLanguages' False
-showiLanguages :: GHCi ()
+showiLanguages :: GHC.GhcMonad m => m ()
showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
showLanguages' :: Bool -> DynFlags -> IO ()
@@ -3151,10 +3163,10 @@ showLanguages' show_all dflags =
Nothing -> Just Haskell2010
other -> other
-showTargets :: GHCi ()
+showTargets :: GHC.GhcMonad m => m ()
showTargets = mapM_ showTarget =<< GHC.getTargets
where
- showTarget :: Target -> GHCi ()
+ showTarget :: GHC.GhcMonad m => Target -> m ()
showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)
showTarget (Target (TargetModule m) _ _) =
liftIO (putStrLn $ moduleNameString m)
@@ -3207,7 +3219,7 @@ completeGhciCommand, completeMacro, completeIdentifier, completeModule,
completeSetModule, completeSeti, completeShowiOptions,
completeHomeModule, completeSetOptions, completeShowOptions,
completeHomeModuleOrFile, completeExpression
- :: CompletionFunc GHCi
+ :: GhciMonad m => CompletionFunc m
-- | Provide completions for last word in a given string.
--
@@ -3283,7 +3295,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
completeHomeModule = wrapIdentCompleter listHomeModules
-listHomeModules :: String -> GHCi [String]
+listHomeModules :: GHC.GhcMonad m => String -> m [String]
listHomeModules w = do
g <- GHC.getModuleGraph
let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)
@@ -3320,14 +3332,16 @@ unionComplete f1 f2 line = do
cs2 <- f2 line
return (cs1 ++ cs2)
-wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m
wrapCompleter breakChars fun = completeWord Nothing breakChars
$ fmap (map simpleCompletion . nubSort) . fun
-wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m
wrapIdentCompleter = wrapCompleter word_break_chars
-wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleterWithModifier
+ :: Monad m
+ => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m
wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
$ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
where
@@ -3345,22 +3359,18 @@ completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
-- -----------------------------------------------------------------------------
-- commands for debugger
-sprintCmd, printCmd, forceCmd :: String -> GHCi ()
-sprintCmd = pprintCommand False False
-printCmd = pprintCommand True False
-forceCmd = pprintCommand False True
-
-pprintCommand :: Bool -> Bool -> String -> GHCi ()
-pprintCommand bind force str = do
- pprintClosureCommand bind force str
+sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()
+sprintCmd = pprintClosureCommand False False
+printCmd = pprintClosureCommand True False
+forceCmd = pprintClosureCommand False True
-stepCmd :: String -> GHCi ()
+stepCmd :: GhciMonad m => String -> m ()
stepCmd arg = withSandboxOnly ":step" $ step arg
where
step [] = doContinue (const True) GHC.SingleStep
step expression = runStmt expression GHC.SingleStep >> return ()
-stepLocalCmd :: String -> GHCi ()
+stepLocalCmd :: GhciMonad m => String -> m ()
stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
where
step expr
@@ -3374,7 +3384,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
current_toplevel_decl <- enclosingTickSpan md loc
doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
-stepModuleCmd :: String -> GHCi ()
+stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
where
step expr
@@ -3388,7 +3398,7 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
doContinue f GHC.SingleStep
-- | Returns the span of the largest tick containing the srcspan given
-enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan
+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan
enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
enclosingTickSpan md (RealSrcSpan src) = do
ticks <- getTickArray md
@@ -3405,33 +3415,32 @@ leftmostLargestRealSrcSpan a b =
`thenCmp`
(realSrcSpanEnd b `compare` realSrcSpanEnd a)
-traceCmd :: String -> GHCi ()
+traceCmd :: GhciMonad m => String -> m ()
traceCmd arg
= withSandboxOnly ":trace" $ tr arg
where
tr [] = doContinue (const True) GHC.RunAndLogSteps
tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
-continueCmd :: String -> GHCi ()
+continueCmd :: GhciMonad m => String -> m ()
continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
--- doContinue :: SingleStep -> GHCi ()
-doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
+doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()
doContinue pre step = do
runResult <- resume pre step
_ <- afterRunStmt pre runResult
return ()
-abandonCmd :: String -> GHCi ()
+abandonCmd :: GhciMonad m => String -> m ()
abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
b <- GHC.abandon -- the prompt will change to indicate the new context
when (not b) $ liftIO $ putStrLn "There is no computation running."
-deleteCmd :: String -> GHCi ()
+deleteCmd :: GhciMonad m => String -> m ()
deleteCmd argLine = withSandboxOnly ":delete" $ do
deleteSwitch $ words argLine
where
- deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch :: GhciMonad m => [String] -> m ()
deleteSwitch [] =
liftIO $ putStrLn "The delete command requires at least one argument."
-- delete all break points
@@ -3439,12 +3448,12 @@ deleteCmd argLine = withSandboxOnly ":delete" $ do
deleteSwitch idents = do
mapM_ deleteOneBreak idents
where
- deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak :: GhciMonad m => String -> m ()
deleteOneBreak str
| all isDigit str = deleteBreak (read str)
| otherwise = return ()
-historyCmd :: String -> GHCi ()
+historyCmd :: GHC.GhcMonad m => String -> m ()
historyCmd arg
| null arg = history 20
| all isDigit arg = history (read arg)
@@ -3475,7 +3484,7 @@ bold :: SDoc -> SDoc
bold c | do_bold = text start_bold <> c <> text end_bold
| otherwise = c
-backCmd :: String -> GHCi ()
+backCmd :: GhciMonad m => String -> m ()
backCmd arg
| null arg = back 1
| all isDigit arg = back (read arg)
@@ -3489,7 +3498,7 @@ backCmd arg
st <- getGHCiState
enqueueCommands [stop st]
-forwardCmd :: String -> GHCi ()
+forwardCmd :: GhciMonad m => String -> m ()
forwardCmd arg
| null arg = forward 1
| all isDigit arg = forward (read arg)
@@ -3506,10 +3515,10 @@ forwardCmd arg
enqueueCommands [stop st]
-- handle the "break" command
-breakCmd :: String -> GHCi ()
+breakCmd :: GhciMonad m => String -> m ()
breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
-breakSwitch :: [String] -> GHCi ()
+breakSwitch :: GhciMonad m => [String] -> m ()
breakSwitch [] = do
liftIO $ putStrLn "The break command requires at least one argument."
breakSwitch (arg1:rest)
@@ -3537,14 +3546,14 @@ breakSwitch (arg1:rest)
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-breakByModule :: Module -> [String] -> GHCi ()
+breakByModule :: GhciMonad m => Module -> [String] -> m ()
breakByModule md (arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine md (read arg1) rest
breakByModule _ _
= breakSyntax
-breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()
breakByModuleLine md line args
| [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
| [col] <- args, all isDigit col =
@@ -3554,7 +3563,8 @@ breakByModuleLine md line args
breakSyntax :: a
breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
-findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()
+findBreakAndSet :: GhciMonad m
+ => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()
findBreakAndSet md lookupTickTree = do
tickArray <- getTickArray md
(breakArray, _) <- getModBreak md
@@ -3657,7 +3667,7 @@ end_bold = "\ESC[0m"
-----------------------------------------------------------------------------
-- :where
-whereCmd :: String -> GHCi ()
+whereCmd :: GHC.GhcMonad m => String -> m ()
whereCmd = noArgs $ do
mstrs <- getCallStackAtCurrentBreakpoint
case mstrs of
@@ -3667,12 +3677,9 @@ whereCmd = noArgs $ do
-----------------------------------------------------------------------------
-- :list
-listCmd :: String -> InputT GHCi ()
-listCmd c = listCmd' c
-
-listCmd' :: String -> InputT GHCi ()
-listCmd' "" = do
- mb_span <- lift getCurrentBreakSpan
+listCmd :: GhciMonad m => String -> m ()
+listCmd "" = do
+ mb_span <- getCurrentBreakSpan
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
@@ -3690,15 +3697,15 @@ listCmd' "" = do
printForUser (text "Unable to list source for" <+>
ppr pan
$$ text "Try" <+> doWhat)
-listCmd' str = list2 (words str)
+listCmd str = list2 (words str)
-list2 :: [String] -> InputT GHCi ()
+list2 :: GhciMonad m => [String] -> m ()
list2 [arg] | all isDigit arg = do
imports <- GHC.getContext
case iiModules imports of
[] -> liftIO $ putStrLn "No module to list"
(mn : _) -> do
- md <- lift $ lookupModuleName mn
+ md <- lookupModuleName mn
listModuleLine md (read arg)
list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
md <- wantInterpretedModule arg1
@@ -3709,7 +3716,7 @@ list2 [arg] = do
case loc of
RealSrcLoc l ->
do tickArray <- ASSERT( isExternalName name )
- lift $ getTickArray (GHC.nameModule name)
+ getTickArray (GHC.nameModule name)
let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
(GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
@@ -3725,7 +3732,7 @@ list2 [arg] = do
list2 _other =
liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
-listModuleLine :: Module -> Int -> InputT GHCi ()
+listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()
listModuleLine modl line = do
graph <- GHC.getModuleGraph
let this = GHC.mgLookupModule graph modl
@@ -3745,7 +3752,7 @@ listModuleLine modl line = do
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
-listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()
listAround pan do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
-- Drop carriage returns to avoid duplicates, see #9367.
@@ -3811,7 +3818,7 @@ listAround pan do_highlight = do
-- --------------------------------------------------------------------------
-- Tick arrays
-getTickArray :: Module -> GHCi TickArray
+getTickArray :: GhciMonad m => Module -> m TickArray
getTickArray modl = do
st <- getGHCiState
let arrmap = tickarrays st
@@ -3823,7 +3830,7 @@ getTickArray modl = do
setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
return arr
-discardTickArrays :: GHCi ()
+discardTickArrays :: GhciMonad m => m ()
discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
@@ -3835,13 +3842,13 @@ mkTickArray ticks
srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
-- don't reset the counter back to zero?
-discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints :: GhciMonad m => m ()
discardActiveBreakPoints = do
st <- getGHCiState
mapM_ (turnOffBreak.snd) (breaks st)
setGHCiState $ st { breaks = [] }
-deleteBreak :: Int -> GHCi ()
+deleteBreak :: GhciMonad m => Int -> m ()
deleteBreak identity = do
st <- getGHCiState
let oldLocations = breaks st
@@ -3853,13 +3860,14 @@ deleteBreak identity = do
mapM_ (turnOffBreak.snd) this
setGHCiState $ st { breaks = rest }
-turnOffBreak :: BreakLocation -> GHCi ()
+turnOffBreak :: GHC.GhcMonad m => BreakLocation -> m ()
turnOffBreak loc = do
(arr, _) <- getModBreak (breakModule loc)
hsc_env <- GHC.getSession
liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
-getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
+getModBreak :: GHC.GhcMonad m
+ => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
getModBreak m = do
mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
let modBreaks = GHC.modInfoModBreaks mod_info
@@ -3867,7 +3875,7 @@ getModBreak m = do
let ticks = GHC.modBreaks_locs modBreaks
return (arr, ticks)
-setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()
+setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()
setBreakFlag toggle arr i = do
hsc_env <- GHC.getSession
liftIO $ enableBreakpoint hsc_env arr i toggle
@@ -3885,14 +3893,13 @@ setBreakFlag toggle arr i = do
-- raising another exception. We therefore don't put the recursive
-- handler arond the flushing operation, so if stderr is closed
-- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: SomeException -> GHCi Bool
-
+handler :: GhciMonad m => SomeException -> m Bool
handler exception = do
flushInterpBuffers
withSignalHandlers $
ghciHandle handler (showException exception >> return False)
-showException :: SomeException -> GHCi ()
+showException :: MonadIO m => SomeException -> m ()
showException se =
liftIO $ case fromException se of
-- omit the location for CmdLineError:
@@ -3920,10 +3927,10 @@ ghciHandle h m = gmask $ \restore -> do
!dflags <- getDynFlags
gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
-ghciTry :: GHCi a -> GHCi (Either SomeException a)
-ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
+ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)
+ghciTry m = fmap Right m `gcatch` \e -> return $ Left e
-tryBool :: GHCi a -> GHCi Bool
+tryBool :: ExceptionMonad m => m a -> m Bool
tryBool m = do
r <- ghciTry m
case r of
@@ -3944,7 +3951,7 @@ isHomeModule m = GHC.moduleUnitId m == mainUnitId
-- TODO: won't work if home dir is encoded.
-- (changeDirectory may not work either in that case.)
-expandPath :: MonadIO m => String -> InputT m String
+expandPath :: MonadIO m => String -> m String
expandPath = liftIO . expandPathIO
expandPathIO :: String -> IO String
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index dddbe824d6..4287c09b8c 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -12,7 +12,7 @@
module GHCi.UI.Monad (
GHCi(..), startGHCi,
- GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
+ GHCiState(..), GhciMonad(..),
GHCiOption(..), isOptionSet, setOption, unsetOption,
Command(..), CommandResult(..), cmdSuccess,
PromptFunction,
@@ -219,7 +219,8 @@ instance Outputable BreakLocation where
then Outputable.empty
else doubleQuotes (text (onBreakCmd loc))
-recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak
+ :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
recordBreak brkLoc = do
st <- getGHCiState
let oldActiveBreaks = breaks st
@@ -239,13 +240,18 @@ newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
-reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
-reifyGHCi f = GHCi f'
- where
- -- f' :: IORef GHCiState -> Ghc a
- f' gs = reifyGhc (f'' gs)
- -- f'' :: IORef GHCiState -> Session -> IO a
- f'' gs s = f (s, gs)
+reifyGHCi :: GhciMonad m => ((Session, IORef GHCiState) -> IO a) -> m a
+reifyGHCi f = do
+ s <- GHC.getSession
+ sRef <- liftIO $ newIORef s
+ gs <- getGHCiState
+ gsRef <- liftIO $ newIORef gs
+ ret <- liftIO (f (Session sRef, gsRef)) `gfinally` do
+ s' <- liftIO $ readIORef sRef
+ GHC.setSession s'
+ gs' <- liftIO $ readIORef gsRef
+ setGHCiState gs'
+ return ret
startGHCi :: GHCi a -> GHCiState -> Ghc a
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
@@ -260,20 +266,20 @@ instance Applicative GHCi where
instance Monad GHCi where
(GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
-class HasGhciState m where
- getGHCiState :: m GHCiState
- setGHCiState :: GHCiState -> m ()
- modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
+class GhcMonad m => GhciMonad m where
+ getGHCiState :: m GHCiState
+ setGHCiState :: GHCiState -> m ()
+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
-instance HasGhciState GHCi where
- getGHCiState = GHCi $ \r -> liftIO $ readIORef r
- setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+instance GhciMonad GHCi where
+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r
+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
-instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
- getGHCiState = lift getGHCiState
- setGHCiState = lift . setGHCiState
- modifyGHCiState = lift . modifyGHCiState
+instance GhciMonad (InputT GHCi) where
+ getGHCiState = lift getGHCiState
+ setGHCiState = lift . setGHCiState
+ modifyGHCiState = lift . modifyGHCiState
liftGhc :: Ghc a -> GHCi a
liftGhc m = GHCi $ \_ -> m
@@ -318,17 +324,17 @@ instance ExceptionMonad (InputT GHCi) where
gcatch = Haskeline.catch
gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
-isOptionSet :: GHCiOption -> GHCi Bool
+isOptionSet :: GhciMonad m => GHCiOption -> m Bool
isOptionSet opt
= do st <- getGHCiState
return (opt `elem` options st)
-setOption :: GHCiOption -> GHCi ()
+setOption :: GhciMonad m => GHCiOption -> m ()
setOption opt
= do st <- getGHCiState
setGHCiState (st{ options = opt : filter (/= opt) (options st) })
-unsetOption :: GHCiOption -> GHCi ()
+unsetOption :: GhciMonad m => GHCiOption -> m ()
unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
@@ -351,14 +357,16 @@ printForUser doc = do
dflags <- getDynFlags
liftIO $ Outputable.printForUser dflags stdout unqual doc
-printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay :: GhcMonad m => SDoc -> m ()
printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
-- | Run a single Haskell expression
-runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
+runStmt
+ :: GhciMonad m
+ => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)
runStmt stmt stmt_text step = do
st <- getGHCiState
GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
@@ -370,7 +378,7 @@ runStmt stmt stmt_text step = do
(EvalThis fhv) }
Just <$> GHC.execStmt' stmt stmt_text opts
-runDecls :: String -> GHCi (Maybe [GHC.Name])
+runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
runDecls decls = do
st <- getGHCiState
reifyGHCi $ \x ->
@@ -382,7 +390,7 @@ runDecls decls = do
r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
return (Just r)
-runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name])
+runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
runDecls' decls = do
st <- getGHCiState
reifyGHCi $ \x ->
@@ -394,7 +402,7 @@ runDecls' decls = do
return Nothing)
(Just <$> GHC.runParsedDecls decls)
-resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
+resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult
resume canLogSpan step = do
st <- getGHCiState
reifyGHCi $ \x ->
@@ -412,14 +420,15 @@ data ActionStats = ActionStats
} deriving Show
runAndPrintStats
- :: (a -> Maybe Integer)
- -> InputT GHCi a
- -> InputT GHCi (ActionStats, Either SomeException a)
+ :: GhciMonad m
+ => (a -> Maybe Integer)
+ -> m a
+ -> m (ActionStats, Either SomeException a)
runAndPrintStats getAllocs action = do
result <- runWithStats getAllocs action
case result of
(stats, Right{}) -> do
- showTiming <- lift $ isOptionSet ShowTiming
+ showTiming <- isOptionSet ShowTiming
when showTiming $ do
dflags <- getDynFlags
liftIO $ printStats dflags stats
@@ -455,7 +464,7 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
-----------------------------------------------------------------------------
-- reverting CAFs
-revertCAFs :: GHCi ()
+revertCAFs :: GhciMonad m => m ()
revertCAFs = do
liftIO rts_revertCAFs
s <- getGHCiState
@@ -483,14 +492,14 @@ initInterpBuffering = do
return (nobuf, flush)
-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
-flushInterpBuffers :: GHCi ()
+flushInterpBuffers :: GhciMonad m => m ()
flushInterpBuffers = do
st <- getGHCiState
hsc_env <- GHC.getSession
liftIO $ evalIO hsc_env (flushStdHandles st)
-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
-turnOffBuffering :: GHCi ()
+turnOffBuffering :: GhciMonad m => m ()
turnOffBuffering = do
st <- getGHCiState
turnOffBuffering_ (noBuffering st)