diff options
author | Zejun Wu <watashi@fb.com> | 2019-01-21 16:28:01 -0800 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2019-01-31 12:46:51 -0500 |
commit | e08974e81ccc84b5887d13cc4752fde9a78c51fb (patch) | |
tree | 0c2d12762972c39f29c25c650735bd5b3570dc38 | |
parent | 1be81c50b51d0c9c651cbdd14bb7cf6884d011ff (diff) | |
download | haskell-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.hs | 403 | ||||
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 81 |
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) |