haskell-dap 0.0.10.1 → 0.0.11.0
raw patch · 12 files changed
+7756/−5764 lines, 12 filesdep ~ghc
Dependency ranges changed: ghc
Files
- Changelog.md +5/−0
- README.md +3/−74
- app-ghc-8.2/GHCi/UI.hs +3826/−3826
- app/Haskell/DAP/GHCi/Command.hs +1488/−1488
- app/Haskell/DAP/GHCi/Constant.hs +37/−37
- app/Haskell/DAP/GHCi/Type.hs +65/−65
- app/Haskell/DAP/GHCi/Utility.hs +188/−188
- app/Main.hs +28/−28
- haskell-dap.cabal +7/−6
- src-c-8.0/HsVersions.h +51/−51
- src/GHCi/DAP.hs +2054/−0
- src/GHCi/DAP/IFData.hs +4/−1
Changelog.md view
@@ -1,4 +1,9 @@ +20190303 haskell-dap-0.0.11.0++ * [ADD] GHCi.DAP module. GHCi.DAP.IFData is deprecated.++ 20190108 haskell-dap-0.0.10.1 * [MODIFY] package.yaml build options.
README.md view
@@ -1,80 +1,9 @@ # haskell-dap -The goal is "let GHCi speak [DAP](https://code.visualstudio.com/docs/extensions/example-debuggers)".-- --## Information--* [2018/12/15] Release haskel-dap-0.0.10.0. - * [MODIFY] supported ghc-8.6---## Limitation-Currently this project is an experimental design and implementation.--* supporting ghc-8.0, ghc-8.2, ghc-8.4, ghc-8.6-* need stack project.-* checked on windows7, centos7--## Features--### inspect watch-- --### inspect hoover-- --### inspect repl-- --### logpoint-- --### break condition-- --### break hit count-- --## Install--install vscode and [phoityne](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) extension.--### Run stack install-- % stack install haskell-dap- . . . . .- Copied executables to C:\Users\[USERNAME]\AppData\Roaming\local\bin:- - haskell-dap.exe-- %--## Configuration--Add `--with-ghc` option to `ghciCmd` variable in the vscode launch.json. --- "ghciCmd": "stack ghci --with-ghc=haskell-dap --test --no-load --no-build --main-is TARGET --ghci-options -fghci-hist-size=5 --ghci-options -fprint-evld-with-show ",----## IFData Design-- -+Haskell implementation of the DAP interface data. -## Sequences+@see : https://microsoft.github.io/debug-adapter-protocol/ -### Overview.- +@see : https://github.com/Microsoft/vscode-debugadapter-node/blob/master/protocol/src/debugProtocol.ts -### Debugging details.-
app-ghc-8.2/GHCi/UI.hs view
@@ -1,3826 +1,3826 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ------------------------------------------------------------------------------ --- --- GHC Interactive User Interface --- --- (c) The GHC Team 2005-2006 --- ------------------------------------------------------------------------------ - -module GHCi.UI ( - interactiveUI, - GhciSettings(..), - ghciCommands, - ghciWelcomeMsg, - - -- haskell-dap add. - defaultGhciSettings, - getLoadedModules, - breakCmd, - deleteCmd, - traceCmd, - stepCmd, - stepLocalCmd, - runStmt, - toBreakIdAndLocation - ) where - -#include "HsVersions.h" - --- GHCi -import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls ) -import GHCi.UI.Monad hiding ( args, runStmt, runDecls ) -import GHCi.UI.Tags -import GHCi.UI.Info -import Debugger - --- The GHC interface -import GHCi -import GHCi.RemoteTypes -import GHCi.BreakArray -import DynFlags -import ErrUtils -import GhcMonad ( modifySession ) -import qualified GHC -import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), - TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, - getModuleGraph, handleSourceError ) -import HsImpExp -import HsSyn -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, - setInteractivePrintName, hsc_dflags, msObjFilePath ) -import Module -import Name -import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, - listVisibleModuleNames, pprFlag ) -import IfaceSyn ( showToHeader ) -import PprTyThing -import PrelNames -import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) -import SrcLoc -import qualified Lexer - -import StringBuffer -import Outputable hiding ( printForUser, printForUserPartWay ) - --- Other random utilities -import BasicTypes hiding ( isTopLevel ) -import Config -import Digraph -import Encoding -import FastString -import Linker -import Maybes ( orElse, expectJust ) -import NameSet -import Panic hiding ( showException ) -import Util -import qualified GHC.LanguageExtensions as LangExt - --- Haskell Libraries -import System.Console.Haskeline as Haskeline - -import Control.Applicative hiding (empty) -import Control.DeepSeq (deepseq) -import Control.Monad as Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except - -import Data.Array -import qualified Data.ByteString.Char8 as BS -import Data.Char -import Data.Function -import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) -import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, - partition, sort, sortBy ) -import qualified Data.Set as S -import Data.Maybe -import qualified Data.Map as M -import Data.Time.LocalTime ( getZonedTime ) -import Data.Time.Format ( formatTime, defaultTimeLocale ) -import Data.Version ( showVersion ) - -import Exception hiding (catch) -import Foreign hiding (void) -import GHC.Stack hiding (SrcLoc(..)) - -import System.Directory -import System.Environment -import System.Exit ( exitWith, ExitCode(..) ) -import System.FilePath -import System.Info -import System.IO -import System.IO.Error -import System.IO.Unsafe ( unsafePerformIO ) -import System.Process -import Text.Printf -import Text.Read ( readMaybe ) -import Text.Read.Lex (isSymbolChar) - -import Unsafe.Coerce - -#ifndef mingw32_HOST_OS -import System.Posix hiding ( getEnv ) -#else -import qualified System.Win32 -#endif - -import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) -import GHC.IO.Handle ( hFlushAll ) -import GHC.TopHandler ( topHandler ) - ------------------------------------------------------------------------------- --- DAP ------------------------------------------------------------------------------- -import qualified Haskell.DAP.GHCi.Type as DAP -import InteractiveEval (ExecResult) -import Control.Concurrent - - ------------------------------------------------------------------------------ - -data GhciSettings = GhciSettings { - availableCommands :: [Command], - shortHelpText :: String, - fullHelpText :: String, - defPrompt :: PromptFunction, - defPromptCont :: PromptFunction, - dapContextGhciSettings :: DAP.MVarDAPContext - } - -defaultGhciSettings :: DAP.MVarDAPContext -> GhciSettings -defaultGhciSettings dapCtx = - GhciSettings { - availableCommands = ghciCommands, - shortHelpText = defShortHelpText, - defPrompt = default_prompt, - defPromptCont = default_prompt_cont, - fullHelpText = defFullHelpText, - dapContextGhciSettings = dapCtx - } - -ghciWelcomeMsg :: String -ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ - ": http://www.haskell.org/ghc/ :? for help" - -ghciCommands :: [Command] -ghciCommands = map mkCmd [ - -- Hugs users are accustomed to :e, so make sure it doesn't overlap - ("?", keepGoing help, noCompletion), - ("add", keepGoingPaths addModule, completeFilename), - ("abandon", keepGoing abandonCmd, noCompletion), - ("break", keepGoing breakCmd, completeIdentifier), - ("back", keepGoing backCmd, noCompletion), - ("browse", keepGoing' (browseCmd False), completeModule), - ("browse!", keepGoing' (browseCmd True), completeModule), - ("cd", keepGoing' changeDirectory, completeFilename), - ("check", keepGoing' checkModule, completeHomeModule), - ("continue", keepGoing continueCmd, noCompletion), - ("cmd", keepGoing cmdCmd, completeExpression), - ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), - ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), - ("def", keepGoing (defineMacro False), completeExpression), - ("def!", keepGoing (defineMacro True), completeExpression), - ("delete", keepGoing deleteCmd, noCompletion), - ("edit", keepGoing' editFile, completeFilename), - ("etags", keepGoing createETagsFileCmd, completeFilename), - ("force", keepGoing forceCmd, completeExpression), - ("forward", keepGoing forwardCmd, noCompletion), - ("help", keepGoing help, noCompletion), - ("history", keepGoing historyCmd, noCompletion), - ("info", keepGoing' (info False), completeIdentifier), - ("info!", keepGoing' (info True), completeIdentifier), - ("issafe", keepGoing' isSafeCmd, completeModule), - ("kind", keepGoing' (kindOfType False), completeIdentifier), - ("kind!", keepGoing' (kindOfType True), completeIdentifier), - ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), - ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), - ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing moduleCmd, completeSetModule), - ("main", keepGoing runMain, completeFilename), - ("print", keepGoing printCmd, completeExpression), - ("quit", quit, noCompletion), - ("reload", keepGoing' reloadModule, noCompletion), - ("reload!", keepGoing' reloadModuleDefer, noCompletion), - ("run", keepGoing runRun, completeFilename), - ("script", keepGoing' scriptCmd, completeFilename), - ("set", keepGoing setCmd, completeSetOptions), - ("seti", keepGoing setiCmd, completeSeti), - ("show", keepGoing showCmd, completeShowOptions), - ("showi", keepGoing showiCmd, completeShowiOptions), - ("sprint", keepGoing sprintCmd, completeExpression), - ("step", keepGoing stepCmd, completeIdentifier), - ("steplocal", keepGoing stepLocalCmd, completeIdentifier), - ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), - ("type", keepGoing' typeOfExpr, completeExpression), - ("trace", keepGoing traceCmd, completeExpression), - ("undef", keepGoing undefineMacro, completeMacro), - ("unset", keepGoing unsetOptions, completeSetOptions), - ("where", keepGoing whereCmd, noCompletion) - ] ++ map mkCmdHidden [ -- hidden commands - ("all-types", keepGoing' allTypesCmd), - ("complete", keepGoing completeCmd), - ("loc-at", keepGoing' locAtCmd), - ("type-at", keepGoing' typeAtCmd), - ("uses", keepGoing' usesCmd) - ] - where - mkCmd (n,a,c) = Command { cmdName = n - , cmdAction = a - , cmdHidden = False - , cmdCompletionFunc = c - } - - mkCmdHidden (n,a) = Command { cmdName = n - , cmdAction = a - , cmdHidden = True - , cmdCompletionFunc = noCompletion - } - --- We initialize readline (in the interactiveUI function) to use --- word_break_chars as the default set of completion word break characters. --- This can be overridden for a particular command (for example, filename --- expansion shouldn't consider '/' to be a word break) by setting the third --- entry in the Command tuple above. --- --- NOTE: in order for us to override the default correctly, any custom entry --- must be a SUBSET of word_break_chars. -word_break_chars :: String -word_break_chars = spaces ++ specials ++ symbols - -symbols, specials, spaces :: String -symbols = "!#$%&*+/<=>?@\\^|-~" -specials = "(),;[]`{}" -spaces = " \t\n" - -flagWordBreakChars :: String -flagWordBreakChars = " \t\n" - - -keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) -keepGoing a str = keepGoing' (lift . a) str - -keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool -keepGoing' a str = a str >> return False - -keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) -keepGoingPaths a str - = do case toArgs str of - Left err -> liftIO $ hPutStrLn stderr err - Right args -> a args - return False - -defShortHelpText :: String -defShortHelpText = "use :? for help.\n" - -defFullHelpText :: String -defFullHelpText = - " Commands available from the prompt:\n" ++ - "\n" ++ - " <statement> evaluate/run <statement>\n" ++ - " : repeat last command\n" ++ - " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ - " :add [*]<module> ... add module(s) to the current target set\n" ++ - " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++ - " (!: more details; *: all top-level names)\n" ++ - " :cd <dir> change directory to <dir>\n" ++ - " :cmd <expr> run the commands returned by <expr>::IO String\n" ++ - " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++ - " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++ - " (!: use regex instead of line number)\n" ++ - " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++ - " precedence, ::<cmd> is always a builtin command)\n" ++ - " :edit <file> edit file\n" ++ - " :edit edit last module\n" ++ - " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++ - " :help, :? display this list of commands\n" ++ - " :info[!] [<name> ...] display information about the given names\n" ++ - " (!: do not filter instances)\n" ++ - " :issafe [<mod>] display safe haskell information of module <mod>\n" ++ - " :kind[!] <type> show the kind of <type>\n" ++ - " (!: also print the normalised type)\n" ++ - " :load[!] [*]<module> ... load module(s) and their dependents\n" ++ - " (!: defer type errors)\n" ++ - " :main [<arguments> ...] run the main function with the given arguments\n" ++ - " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++ - " :quit exit GHCi\n" ++ - " :reload[!] reload the current module set\n" ++ - " (!: defer type errors)\n" ++ - " :run function [<arguments> ...] run the function with the given arguments\n" ++ - " :script <file> run the script <file>\n" ++ - " :type <expr> show the type of <expr>\n" ++ - " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++ - " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++ - " :undef <cmd> undefine user-defined command :<cmd>\n" ++ - " :!<command> run the shell command <command>\n" ++ - "\n" ++ - " -- Commands for debugging:\n" ++ - "\n" ++ - " :abandon at a breakpoint, abandon current computation\n" ++ - " :back [<n>] go back in the history N steps (after :trace)\n" ++ - " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++ - " :break <name> set a breakpoint on the specified function\n" ++ - " :continue resume after a breakpoint\n" ++ - " :delete <number> delete the specified breakpoint\n" ++ - " :delete * delete all breakpoints\n" ++ - " :force <expr> print <expr>, forcing unevaluated parts\n" ++ - " :forward [<n>] go forward in the history N step s(after :back)\n" ++ - " :history [<n>] after :trace, show the execution history\n" ++ - " :list show the source code around current breakpoint\n" ++ - " :list <identifier> show the source code for <identifier>\n" ++ - " :list [<module>] <line> show the source code around line number <line>\n" ++ - " :print [<name> ...] show a value without forcing its computation\n" ++ - " :sprint [<name> ...] simplified version of :print\n" ++ - " :step single-step after stopping at a breakpoint\n"++ - " :step <expr> single-step into <expr>\n"++ - " :steplocal single-step within the current top-level binding\n"++ - " :stepmodule single-step restricted to the current module\n"++ - " :trace trace after stopping at a breakpoint\n"++ - " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ - - "\n" ++ - " -- Commands for changing settings:\n" ++ - "\n" ++ - " :set <option> ... set options\n" ++ - " :seti <option> ... set options for interactive evaluation only\n" ++ - " :set args <arg> ... set the arguments returned by System.getArgs\n" ++ - " :set prog <progname> set the value returned by System.getProgName\n" ++ - " :set prompt <prompt> set the prompt used in GHCi\n" ++ - " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++ - " :set prompt-function <expr> set the function to handle the prompt\n" ++ - " :set prompt-cont-function <expr>" ++ - "set the function to handle the continuation prompt\n" ++ - " :set editor <cmd> set the command used for :edit\n" ++ - " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++ - " :unset <option> ... unset options\n" ++ - "\n" ++ - " Options for ':set' and ':unset':\n" ++ - "\n" ++ - " +m allow multiline commands\n" ++ - " +r revert top-level expressions after each evaluation\n" ++ - " +s print timing/memory stats after each evaluation\n" ++ - " +t print type after evaluation\n" ++ - " +c collect type/location info after loading modules\n" ++ - " -<flags> most GHC command line flags can also be set here\n" ++ - " (eg. -v2, -XFlexibleInstances, etc.)\n" ++ - " for GHCi-specific flags, see User's Guide,\n"++ - " Flag reference, Interactive-mode options\n" ++ - "\n" ++ - " -- Commands for displaying information:\n" ++ - "\n" ++ - " :show bindings show the current bindings made at the prompt\n" ++ - " :show breaks show the active breakpoints\n" ++ - " :show context show the breakpoint context\n" ++ - " :show imports show the current imports\n" ++ - " :show linker show current linker state\n" ++ - " :show modules show the currently loaded modules\n" ++ - " :show packages show the currently active package flags\n" ++ - " :show paths show the currently active search paths\n" ++ - " :show language show the currently active language flags\n" ++ - " :show <setting> show value of <setting>, which is one of\n" ++ - " [args, prog, editor, stop]\n" ++ - " :showi language show language flags for interactive evaluation\n" ++ - "\n" - -findEditor :: IO String -findEditor = do - getEnv "EDITOR" - `catchIO` \_ -> do -#if mingw32_HOST_OS - win <- System.Win32.getWindowsDirectory - return (win </> "notepad.exe") -#else - return "" -#endif - -default_progname, default_stop :: String -default_progname = "<interactive>" -default_stop = "" - -default_prompt, default_prompt_cont :: PromptFunction -default_prompt = generatePromptFunctionFromString "%s> " -default_prompt_cont = generatePromptFunctionFromString "%s| " - -default_args :: [String] -default_args = [] - -interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] - -> Ghc () -interactiveUI config srcs maybe_exprs = do - -- HACK! If we happen to get into an infinite loop (eg the user - -- types 'let x=x in x' at the prompt), then the thread will block - -- on a blackhole, and become unreachable during GC. The GC will - -- detect that it is unreachable and send it the NonTermination - -- exception. However, since the thread is unreachable, everything - -- it refers to might be finalized, including the standard Handles. - -- This sounds like a bug, but we don't have a good solution right - -- now. - _ <- liftIO $ newStablePtr stdin - _ <- liftIO $ newStablePtr stdout - _ <- liftIO $ newStablePtr stderr - - -- Initialise buffering for the *interpreted* I/O system - (nobuffering, flush) <- initInterpBuffering - - -- The initial set of DynFlags used for interactive evaluation is the same - -- as the global DynFlags, plus -XExtendedDefaultRules and - -- -XNoMonomorphismRestriction. - dflags <- getDynFlags - let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules) - . (`xopt_unset` LangExt.MonomorphismRestriction) - $ dflags - GHC.setInteractiveDynFlags dflags' - - lastErrLocationsRef <- liftIO $ newIORef [] - progDynFlags <- GHC.getProgramDynFlags - _ <- GHC.setProgramDynFlags $ - progDynFlags { log_action = ghciLogAction lastErrLocationsRef } - - when (isNothing maybe_exprs) $ do - -- Only for GHCi (not runghc and ghc -e): - - -- Turn buffering off for the compiled program's stdout/stderr - turnOffBuffering_ nobuffering - -- Turn buffering off for GHCi's stdout - liftIO $ hFlush stdout - liftIO $ hSetBuffering stdout NoBuffering - -- We don't want the cmd line to buffer any input that might be - -- intended for the program, so unbuffer stdin. - liftIO $ hSetBuffering stdin NoBuffering - liftIO $ hSetBuffering stderr NoBuffering -#if defined(mingw32_HOST_OS) - -- On Unix, stdin will use the locale encoding. The IO library - -- doesn't do this on Windows (yet), so for now we use UTF-8, - -- for consistency with GHC 6.10 and to make the tests work. - liftIO $ hSetEncoding stdin utf8 -#endif - - default_editor <- liftIO $ findEditor - eval_wrapper <- mkEvalWrapper default_progname default_args - let prelude_import = simpleImportDecl preludeModuleName - startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = default_progname, - args = default_args, - evalWrapper = eval_wrapper, - prompt = default_prompt, - prompt_cont = default_prompt_cont, - stop = default_stop, - editor = default_editor, - options = [], - -- We initialize line number as 0, not 1, because we use - -- current line number while reporting errors which is - -- incremented after reading a line. - line_number = 0, - break_ctr = 0, - breaks = [], - tickarrays = emptyModuleEnv, - ghci_commands = availableCommands config, - ghci_macros = [], - last_command = Nothing, - cmdqueue = [], - remembered_ctx = [], - transient_ctx = [], - extra_imports = [], - prelude_imports = [prelude_import], - ghc_e = isJust maybe_exprs, - short_help = shortHelpText config, - long_help = fullHelpText config, - lastErrorLocations = lastErrLocationsRef, - mod_infos = M.empty, - flushStdHandles = flush, - noBuffering = nobuffering, - dapContextGHCiState = dapContextGhciSettings config - } - - return () - -resetLastErrorLocations :: GHCi () -resetLastErrorLocations = do - st <- getGHCiState - liftIO $ writeIORef (lastErrorLocations st) [] - -ghciLogAction :: IORef [(FastString, Int)] -> LogAction -ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do - defaultLogAction dflags flag severity srcSpan style msg - case severity of - SevError -> case srcSpan of - RealSrcSpan rsp -> modifyIORef lastErrLocations - (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) - _ -> return () - _ -> return () - -withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a -withGhcAppData right left = do - either_dir <- tryIO (getAppUserDataDirectory "ghc") - case either_dir of - Right dir -> - do createDirectoryIfMissing False dir `catchIO` \_ -> return () - right dir - _ -> left - -runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () -runGHCi paths maybe_exprs = do - dflags <- getDynFlags - let - ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags - - current_dir = return (Just ".ghci") - - app_user_dir = liftIO $ withGhcAppData - (\dir -> return (Just (dir </> "ghci.conf"))) - (return Nothing) - - home_dir = do - either_dir <- liftIO $ tryIO (getEnv "HOME") - case either_dir of - Right home -> return (Just (home </> ".ghci")) - _ -> return Nothing - - canonicalizePath' :: FilePath -> IO (Maybe FilePath) - canonicalizePath' fp = liftM Just (canonicalizePath fp) - `catchIO` \_ -> return Nothing - - sourceConfigFile :: FilePath -> GHCi () - sourceConfigFile file = do - exists <- liftIO $ doesFileExist file - when exists $ do - either_hdl <- liftIO $ tryIO (openFile file ReadMode) - case either_hdl of - Left _e -> return () - -- NOTE: this assumes that runInputT won't affect the terminal; - -- can we assume this will always be the case? - -- This would be a good place for runFileInputT. - Right hdl -> - do runInputTWithPrefs defaultPrefs defaultSettings $ - runCommands $ fileLoop hdl - liftIO (hClose hdl `catchIO` \_ -> return ()) - -- Don't print a message if this is really ghc -e (#11478). - -- Also, let the user silence the message with -v0 - -- (the default verbosity in GHCi is 1). - when (isNothing maybe_exprs && verbosity dflags > 0) $ - liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file) - - -- - - setGHCContextFromGHCiState - - dot_cfgs <- if ignore_dot_ghci then return [] else do - dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ] - liftIO $ filterM checkFileAndDirPerms dot_files - mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs - - let arg_cfgs = reverse $ ghciScripts dflags - -- -ghci-script are collected in reverse order - -- We don't require that a script explicitly added by -ghci-script - -- is owned by the current user. (#6017) - mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs - -- nub, because we don't want to read .ghci twice if the CWD is $HOME. - - -- Perform a :load for files given on the GHCi command line - -- When in -e mode, if the load fails then we want to stop - -- immediately rather than going on to evaluate the expression. - when (not (null paths)) $ do - ok <- ghciHandle (\e -> do showException e; return Failed) $ - -- TODO: this is a hack. - runInputTWithPrefs defaultPrefs defaultSettings $ - loadModule paths - when (isJust maybe_exprs && failed ok) $ - liftIO (exitWith (ExitFailure 1)) - - installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs) - - -- if verbosity is greater than 0, or we are connected to a - -- terminal, display the prompt in the interactive loop. - -- is_tty <- liftIO (hIsTerminalDevice stdin) - is_tty <- liftIO (return True) - let show_prompt = verbosity dflags > 0 || is_tty - - -- reset line number - modifyGHCiState $ \st -> st{line_number=0} - - case maybe_exprs of - Nothing -> - do - -- enter the interactive loop - runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty - Just exprs -> do - -- just evaluate the expression we were given - enqueueCommands exprs - let hdle e = do st <- getGHCiState - -- flush the interpreter's stdout/stderr on exit (#3890) - flushInterpBuffers - -- Jump through some hoops to get the - -- current progname in the exception text: - -- <progname>: <exception> - liftIO $ withProgName (progname st) - $ topHandler e - -- this used to be topHandlerFastExit, see #2228 - runInputTWithPrefs defaultPrefs defaultSettings $ do - -- make `ghc -e` exit nonzero on invalid input, see Trac #7962 - _ <- runCommands' hdle - (Just $ hdle (toException $ ExitFailure 1) >> return ()) - (return Nothing) - return () - - -- and finally, exit - liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." - -runGHCiInput :: InputT GHCi a -> GHCi a -runGHCiInput f = do - dflags <- getDynFlags - let ghciHistory = gopt Opt_GhciHistory dflags - let localGhciHistory = gopt Opt_LocalGhciHistory dflags - currentDirectory <- liftIO $ getCurrentDirectory - - histFile <- case (ghciHistory, localGhciHistory) of - (True, True) -> return (Just (currentDirectory </> ".ghci_history")) - (True, _) -> liftIO $ withGhcAppData - (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing) - _ -> return Nothing - - runInputT - (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) - f - --- | How to get the next input line from the user -nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) -nextInputLine show_prompt is_tty - | is_tty = do - prmpt <- if show_prompt then lift mkPrompt else return "" - r <- getInputLine prmpt - incrementLineNo - return r - | otherwise = do - when show_prompt $ lift mkPrompt >>= liftIO . putStr - fileLoop stdin - --- NOTE: We only read .ghci files if they are owned by the current user, --- and aren't world writable (files owned by root are ok, see #9324). --- Otherwise, we could be accidentally running code planted by --- a malicious third party. - --- Furthermore, We only read ./.ghci if . is owned by the current user --- and isn't writable by anyone else. I think this is sufficient: we --- don't need to check .. and ../.. etc. because "." always refers to --- the same directory while a process is running. - -checkFileAndDirPerms :: FilePath -> IO Bool -checkFileAndDirPerms file = do - file_ok <- checkPerms file - -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will - -- print some confusing and useless warnings in some cases (e.g. in - -- travis). Note that we can't add a test for this, as all ghci tests should - -- run with -ignore-dot-ghci, which means we never get here. - if file_ok then checkPerms (getDirectory file) else return False - where - getDirectory f = case takeDirectory f of - "" -> "." - d -> d - -checkPerms :: FilePath -> IO Bool -#ifdef mingw32_HOST_OS -checkPerms _ = return True -#else -checkPerms file = - handleIO (\_ -> return False) $ do - st <- getFileStatus file - me <- getRealUserID - let mode = System.Posix.fileMode st - ok = (fileOwner st == me || fileOwner st == 0) && - groupWriteMode /= mode `intersectFileModes` groupWriteMode && - otherWriteMode /= mode `intersectFileModes` otherWriteMode - unless ok $ - -- #8248: Improving warning to include a possible fix. - putStrLn $ "*** WARNING: " ++ file ++ - " is writable by someone else, IGNORING!" ++ - "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'" - return ok -#endif - -incrementLineNo :: InputT GHCi () -incrementLineNo = modifyGHCiState incLineNo - where - incLineNo st = st { line_number = line_number st + 1 } - -fileLoop :: Handle -> InputT GHCi (Maybe String) -fileLoop hdl = do - l <- liftIO $ tryIO $ hGetLine hdl - case l of - Left e | isEOFError e -> return Nothing - | -- as we share stdin with the program, the program - -- might have already closed it, so we might get a - -- handle-closed exception. We therefore catch that - -- too. - isIllegalOperation e -> return Nothing - | InvalidArgument <- etype -> return Nothing - | otherwise -> liftIO $ ioError e - where etype = ioeGetErrorType e - -- treat InvalidArgument in the same way as EOF: - -- this can happen if the user closed stdin, or - -- perhaps did getContents which closes stdin at - -- EOF. - Right l' -> do - incrementLineNo - return (Just l') - -formatCurrentTime :: String -> IO String -formatCurrentTime format = - getZonedTime >>= return . (formatTime defaultTimeLocale format) - -getUserName :: IO String -getUserName = do -#ifdef mingw32_HOST_OS - getEnv "USERNAME" - `catchIO` \e -> do - putStrLn $ show e - return "" -#else - getLoginName -#endif - -getInfoForPrompt :: GHCi (SDoc, [String], Int) -getInfoForPrompt = do - st <- getGHCiState - imports <- GHC.getContext - resumes <- GHC.getResumeContext - - context_bit <- - case resumes of - [] -> return empty - r:_ -> do - let ix = GHC.resumeHistoryIx r - if ix == 0 - then return (brackets (ppr (GHC.resumeSpan r)) <> space) - else do - let hist = GHC.resumeHistory r !! (ix-1) - pan <- GHC.getHistorySpan hist - return (brackets (ppr (negate ix) <> char ':' - <+> ppr pan) <> space) - - let - dots | _:rs <- resumes, not (null rs) = text "... " - | otherwise = empty - - rev_imports = reverse imports -- rightmost are the most recent - - myIdeclName d | Just m <- ideclAs d = unLoc m - | otherwise = unLoc (ideclName d) - - modules_names = - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++ - [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports] - line = 1 + line_number st - - return (dots <> context_bit, modules_names, line) - -parseCallEscape :: String -> (String, String) -parseCallEscape s - | not (all isSpace beforeOpen) = ("", "") - | null sinceOpen = ("", "") - | null sinceClosed = ("", "") - | null cmd = ("", "") - | otherwise = (cmd, tail sinceClosed) - where - (beforeOpen, sinceOpen) = span (/='(') s - (cmd, sinceClosed) = span (/=')') (tail sinceOpen) - -checkPromptStringForErrors :: String -> Maybe String -checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) = - case parseCallEscape xs of - ("", "") -> Just ("Incorrect %call syntax. " ++ - "Should be %call(a command and arguments).") - (_, afterClosed) -> checkPromptStringForErrors afterClosed -checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs -checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs -checkPromptStringForErrors "" = Nothing - -generatePromptFunctionFromString :: String -> PromptFunction -generatePromptFunctionFromString promptS = \_ _ -> do - (context, modules_names, line) <- getInfoForPrompt - - let - processString :: String -> GHCi SDoc - processString ('%':'s':xs) = - liftM2 (<>) (return modules_list) (processString xs) - where - modules_list = context <> modules_bit - modules_bit = hsep $ map text modules_names - processString ('%':'l':xs) = - liftM2 (<>) (return $ ppr line) (processString xs) - processString ('%':'d':xs) = - liftM2 (<>) (liftM text formatted_time) (processString xs) - where - formatted_time = liftIO $ formatCurrentTime "%a %b %d" - processString ('%':'t':xs) = - liftM2 (<>) (liftM text formatted_time) (processString xs) - where - formatted_time = liftIO $ formatCurrentTime "%H:%M:%S" - processString ('%':'T':xs) = do - liftM2 (<>) (liftM text formatted_time) (processString xs) - where - formatted_time = liftIO $ formatCurrentTime "%I:%M:%S" - processString ('%':'@':xs) = do - liftM2 (<>) (liftM text formatted_time) (processString xs) - where - formatted_time = liftIO $ formatCurrentTime "%I:%M %P" - processString ('%':'A':xs) = do - liftM2 (<>) (liftM text formatted_time) (processString xs) - where - formatted_time = liftIO $ formatCurrentTime "%H:%M" - processString ('%':'u':xs) = - liftM2 (<>) (liftM text user_name) (processString xs) - where - user_name = liftIO $ getUserName - processString ('%':'w':xs) = - liftM2 (<>) (liftM text current_directory) (processString xs) - where - current_directory = liftIO $ getCurrentDirectory - processString ('%':'o':xs) = - liftM ((text os) <>) (processString xs) - processString ('%':'a':xs) = - liftM ((text arch) <>) (processString xs) - processString ('%':'N':xs) = - liftM ((text compilerName) <>) (processString xs) - processString ('%':'V':xs) = - liftM ((text $ showVersion compilerVersion) <>) (processString xs) - processString ('%':'c':'a':'l':'l':xs) = do - respond <- liftIO $ do - (code, out, err) <- - readProcessWithExitCode - (head list_words) (tail list_words) "" - `catchIO` \e -> return (ExitFailure 1, "", show e) - case code of - ExitSuccess -> return out - _ -> do - hPutStrLn stderr err - return "" - liftM ((text respond) <>) (processString afterClosed) - where - (cmd, afterClosed) = parseCallEscape xs - list_words = words cmd - processString ('%':'%':xs) = - liftM ((char '%') <>) (processString xs) - processString (x:xs) = - liftM (char x <>) (processString xs) - processString "" = - return empty - - processString promptS - -mkPrompt :: GHCi String -mkPrompt = do - st <- getGHCiState - dflags <- getDynFlags - (context, modules_names, line) <- getInfoForPrompt - - prompt_string <- (prompt st) modules_names line - let prompt_doc = context <> prompt_string - - return (showSDoc dflags prompt_doc) - -queryQueue :: GHCi (Maybe String) -queryQueue = do - st <- getGHCiState - case cmdqueue st of - [] -> return Nothing - c:cs -> do setGHCiState st{ cmdqueue = cs } - return (Just c) - --- Reconfigurable pretty-printing Ticket #5461 -installInteractivePrint :: Maybe String -> Bool -> GHCi () -installInteractivePrint Nothing _ = return () -installInteractivePrint (Just ipFun) exprmode = do - ok <- trySuccess $ do - (name:_) <- GHC.parseName ipFun - modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name - in he{hsc_IC = new_ic}) - return Succeeded - - when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1)) - --- | The main read-eval-print loop -runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () -runCommands gCmd = runCommands' handler Nothing gCmd >> return () - -runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler - -> Maybe (GHCi ()) -- ^ Source error handler - -> InputT GHCi (Maybe String) - -> InputT GHCi (Maybe Bool) - -- We want to return () here, but have to return (Maybe Bool) - -- because gmask is not polymorphic enough: we want to use - -- unmask at two different types. -runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do - b <- ghandle (\e -> case fromException e of - Just UserInterrupt -> return $ Just False - _ -> case fromException e of - Just ghce -> - do liftIO (print (ghce :: GhcException)) - return Nothing - _other -> - liftIO (Exception.throwIO e)) - (unmask $ runOneCommand eh gCmd) - case b of - Nothing -> return Nothing - Just success -> do - unless success $ maybe (return ()) lift sourceErrorHandler - unmask $ runCommands' eh sourceErrorHandler gCmd - --- | Evaluate a single line of user input (either :<command> or Haskell code). --- A result of Nothing means there was no more input to process. --- Otherwise the result is Just b where b is True if the command succeeded; --- this is relevant only to ghc -e, which will exit with status 1 --- if the commmand was unsuccessful. GHCi will continue in either case. -runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) - -> InputT GHCi (Maybe Bool) -runOneCommand eh gCmd = do - -- run a previously queued command if there is one, otherwise get new - -- input from user - mb_cmd0 <- noSpace (lift queryQueue) - mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0 - case mb_cmd1 of - Nothing -> return Nothing - Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $ - handleSourceError printErrorAndFail - (doCommand c) - -- source error's are handled by runStmt - -- is the handler necessary here? - where - printErrorAndFail err = do - GHC.printException err - return $ Just False -- Exit ghc -e, but not GHCi - - noSpace q = q >>= maybe (return Nothing) - (\c -> case removeSpaces c of - "" -> noSpace q - ":{" -> multiLineCmd q - _ -> return (Just c) ) - multiLineCmd q = do - st <- getGHCiState - let p = prompt st - setGHCiState st{ prompt = prompt_cont st } - mb_cmd <- collectCommand q "" `GHC.gfinally` - modifyGHCiState (\st' -> st' { prompt = p }) - return mb_cmd - -- we can't use removeSpaces for the sublines here, so - -- multiline commands are somewhat more brittle against - -- fileformat errors (such as \r in dos input on unix), - -- we get rid of any extra spaces for the ":}" test; - -- we also avoid silent failure if ":}" is not found; - -- and since there is no (?) valid occurrence of \r (as - -- opposed to its String representation, "\r") inside a - -- ghci command, we replace any such with ' ' (argh:-( - collectCommand q c = q >>= - maybe (liftIO (ioError collectError)) - (\l->if removeSpaces l == ":}" - then return (Just c) - else collectCommand q (c ++ "\n" ++ map normSpace l)) - where normSpace '\r' = ' ' - normSpace x = x - -- SDM (2007-11-07): is userError the one to use here? - collectError = userError "unterminated multiline command :{ .. :}" - - -- | Handle a line of input - doCommand :: String -> InputT GHCi (Maybe Bool) - - -- command - doCommand stmt | (':' : cmd) <- removeSpaces stmt = do - result <- specialCommand cmd - case result of - True -> return Nothing - _ -> return $ Just True - - -- haskell - doCommand stmt = do - -- if 'stmt' was entered via ':{' it will contain '\n's - let stmt_nl_cnt = length [ () | '\n' <- stmt ] - ml <- lift $ isOptionSet Multiline - if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input - then do - fst_line_num <- line_number <$> getGHCiState - mb_stmt <- checkInputForLayout stmt gCmd - case mb_stmt of - Nothing -> return $ Just True - Just ml_stmt -> do - -- temporarily compensate line-number for multi-line input - result <- timeIt runAllocs $ lift $ - runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion - return $ Just (runSuccess result) - else do -- single line input and :{ - multiline input - last_line_num <- line_number <$> getGHCiState - -- reconstruct first line num from last line num and stmt - let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1) - | otherwise = last_line_num -- single line input - stmt_nl_cnt2 = length [ () | '\n' <- stmt' ] - stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines - -- temporarily compensate line-number for multi-line input - result <- timeIt runAllocs $ lift $ - runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion - return $ Just (runSuccess result) - - -- runStmt wrapper for temporarily overridden line-number - runStmtWithLineNum :: Int -> String -> SingleStep - -> GHCi (Maybe GHC.ExecResult) - runStmtWithLineNum lnum stmt step = do - st0 <- getGHCiState - setGHCiState st0 { line_number = lnum } - result <- runStmt stmt step - -- restore original line_number - getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 } - return result - - -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines' - dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s - , all isSpace l0 = dropLeadingWhiteLines r - | otherwise = s - - --- #4316 --- lex the input. If there is an unclosed layout context, request input -checkInputForLayout :: String -> InputT GHCi (Maybe String) - -> InputT GHCi (Maybe String) -checkInputForLayout stmt getStmt = do - dflags' <- getDynFlags - let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule - st0 <- getGHCiState - let buf' = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1 - pstate = Lexer.mkPState dflags buf' loc - case Lexer.unP goToEnd pstate of - (Lexer.POk _ False) -> return $ Just stmt - _other -> do - st1 <- getGHCiState - let p = prompt st1 - setGHCiState st1{ prompt = prompt_cont st1 } - mb_stmt <- ghciHandle (\ex -> case fromException ex of - Just UserInterrupt -> return Nothing - _ -> case fromException ex of - Just ghce -> - do liftIO (print (ghce :: GhcException)) - return Nothing - _other -> liftIO (Exception.throwIO ex)) - getStmt - modifyGHCiState (\st' -> st' { prompt = p }) - -- the recursive call does not recycle parser state - -- as we use a new string buffer - case mb_stmt of - Nothing -> return Nothing - Just str -> if str == "" - then return $ Just stmt - else do - checkInputForLayout (stmt++"\n"++str) getStmt - where goToEnd = do - eof <- Lexer.nextIsEOF - if eof - then Lexer.activeContext - else Lexer.lexer False return >> goToEnd - -enqueueCommands :: [String] -> GHCi () -enqueueCommands cmds = do - -- make sure we force any exceptions in the commands while we're - -- still inside the exception handler, otherwise bad things will - -- happen (see #10501) - cmds `deepseq` return () - modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st } - --- | 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 stmt step = do - dflags <- GHC.getInteractiveDynFlags - if | GHC.isStmt dflags stmt -> run_stmt - | GHC.isImport dflags stmt -> run_import - -- Every import declaration should be handled by `run_import`. As GHCi - -- in general only accepts one command at a time, we simply throw an - -- exception when the input contains multiple commands of which at least - -- one is an import command (see #10663). - | GHC.hasImport dflags stmt -> throwGhcException - (CmdLineError "error: expecting a single import declaration") - -- Note: `GHC.isDecl` returns False on input like - -- `data Infix a b = a :@: b; infixl 4 :@:` - -- and should therefore not be used here. - | otherwise -> run_decl - - where - run_import = do - addImportToContext stmt - return (Just (GHC.ExecComplete (Right []) 0)) - - run_decl = - do _ <- liftIO $ tryIO $ hFlushAll stdin - m_result <- GhciMonad.runDecls stmt - case m_result of - Nothing -> return Nothing - Just result -> - Just <$> afterRunStmt (const True) - (GHC.ExecComplete (Right result) 0) - - run_stmt = - do -- In the new IO library, read handles buffer data even if the Handle - -- is set to NoBuffering. This causes problems for GHCi where there - -- are really two stdin Handles. So we flush any bufferred data in - -- GHCi's stdin Handle here (only relevant if stdin is attached to - -- a file, otherwise the read buffer can't be flushed). - _ <- liftIO $ tryIO $ hFlushAll stdin - m_result <- GhciMonad.runStmt stmt step - case m_result of - Nothing -> return Nothing - Just result -> Just <$> afterRunStmt (const True) result - --- | Clean up the GHCi environment after a statement has run -afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult -afterRunStmt step_here run_result = do - resumes <- GHC.getResumeContext - case run_result of - GHC.ExecComplete{..} -> - case execResult of - Left ex -> liftIO $ Exception.throwIO ex - Right names -> do - show_types <- isOptionSet ShowType - when show_types $ printTypeOfNames names - GHC.ExecBreak names mb_info - | isNothing mb_info || - step_here (GHC.resumeSpan $ head resumes) -> do - mb_id_loc <- toBreakIdAndLocation mb_info - let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc - if (null bCmd) - then printStoppedAtBreakInfo (head resumes) names - else enqueueCommands [bCmd] - -- run the command set with ":set stop <cmd>" - st <- getGHCiState - enqueueCommands [stop st] - return () - | otherwise -> resume step_here GHC.SingleStep >>= - afterRunStmt step_here >> return () - - flushInterpBuffers - withSignalHandlers $ do - b <- isOptionSet RevertCAFs - when b revertCAFs - - return run_result - -runSuccess :: Maybe GHC.ExecResult -> Bool -runSuccess run_result - | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True - | otherwise = False - -runAllocs :: Maybe GHC.ExecResult -> Maybe Integer -runAllocs m = do - res <- m - case res of - GHC.ExecComplete{..} -> Just (fromIntegral execAllocation) - _ -> Nothing - -toBreakIdAndLocation :: - Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation)) -toBreakIdAndLocation Nothing = return Nothing -toBreakIdAndLocation (Just inf) = do - let md = GHC.breakInfo_module inf - nm = GHC.breakInfo_number inf - st <- getGHCiState - return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st, - breakModule loc == md, - breakTick loc == nm ] - -printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi () -printStoppedAtBreakInfo res names = do - printForUser $ pprStopped res - -- printTypeOfNames session names - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [i | AnId i <- tythings] - printForUserPartWay $ vcat docs - -printTypeOfNames :: [Name] -> GHCi () -printTypeOfNames names - = mapM_ (printTypeOfName ) $ sortBy compareNames names - -compareNames :: Name -> Name -> Ordering -n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2 - where compareWith n = (getOccString n, getSrcSpan n) - -printTypeOfName :: Name -> GHCi () -printTypeOfName n - = do maybe_tything <- GHC.lookupName n - case maybe_tything of - Nothing -> return () - Just thing -> printTyThing thing - - -data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand - --- | Entry point for execution a ':<command>' input from user -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 - htxt <- short_help <$> getGHCiState - case maybe_cmd of - GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest) - BadCommand -> - do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" - ++ htxt) - return False - NoLastCommand -> - do liftIO $ hPutStr stdout ("there is no last command to perform\n" - ++ htxt) - return False - -shellEscape :: String -> GHCi Bool -shellEscape str = liftIO (system str >> return False) - -lookupCommand :: String -> GHCi (MaybeCommand) -lookupCommand "" = do - st <- getGHCiState - case last_command st of - Just c -> return $ GotCommand c - Nothing -> return NoLastCommand -lookupCommand str = do - mc <- lookupCommand' str - modifyGHCiState (\st -> st { last_command = mc }) - return $ case mc of - Just c -> GotCommand c - Nothing -> BadCommand - -lookupCommand' :: String -> GHCi (Maybe Command) -lookupCommand' ":" = return Nothing -lookupCommand' str' = do - macros <- ghci_macros <$> getGHCiState - ghci_cmds <- ghci_commands <$> getGHCiState - - let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds - - let (str, xcmds) = case str' of - ':' : rest -> (rest, []) -- "::" selects a builtin command - _ -> (str', macros) -- otherwise include macros in lookup - - lookupExact s = find $ (s ==) . cmdName - lookupPrefix s = find $ (s `isPrefixOf`) . cmdName - - -- hidden commands can only be matched exact - builtinPfxMatch = lookupPrefix str ghci_cmds_nohide - - -- first, look for exact match (while preferring macros); then, look - -- for first prefix match (preferring builtins), *unless* a macro - -- overrides the builtin; see #8305 for motivation - return $ lookupExact str xcmds <|> - lookupExact str ghci_cmds <|> - (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|> - builtinPfxMatch <|> - lookupPrefix str xcmds - -getCurrentBreakSpan :: GHCi (Maybe SrcSpan) -getCurrentBreakSpan = do - resumes <- GHC.getResumeContext - case resumes of - [] -> return Nothing - (r:_) -> do - let ix = GHC.resumeHistoryIx r - if ix == 0 - then return (Just (GHC.resumeSpan r)) - else do - let hist = GHC.resumeHistory r !! (ix-1) - pan <- GHC.getHistorySpan hist - return (Just pan) - -getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String]) -getCallStackAtCurrentBreakpoint = do - resumes <- GHC.getResumeContext - case resumes of - [] -> return Nothing - (r:_) -> do - hsc_env <- GHC.getSession - Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r)) - -getCurrentBreakModule :: GHCi (Maybe Module) -getCurrentBreakModule = do - resumes <- GHC.getResumeContext - case resumes of - [] -> return Nothing - (r:_) -> do - let ix = GHC.resumeHistoryIx r - if ix == 0 - then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) - else do - let hist = GHC.resumeHistory r !! (ix-1) - return $ Just $ GHC.getHistoryModule hist - ------------------------------------------------------------------------------ --- --- Commands --- ------------------------------------------------------------------------------ - -noArgs :: GHCi () -> String -> GHCi () -noArgs m "" = m -noArgs _ _ = liftIO $ putStrLn "This command takes no arguments" - -withSandboxOnly :: String -> GHCi () -> GHCi () -withSandboxOnly cmd this = do - dflags <- getDynFlags - if not (gopt Opt_GhciSandbox dflags) - then printForUser (text cmd <+> - ptext (sLit "is not supported with -fno-ghci-sandbox")) - else this - ------------------------------------------------------------------------------ --- :help - -help :: String -> GHCi () -help _ = do - txt <- long_help `fmap` getGHCiState - liftIO $ putStr txt - ------------------------------------------------------------------------------ --- :info - -info :: Bool -> String -> InputT GHCi () -info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'") -info allInfo s = handleSourceError GHC.printException $ do - unqual <- GHC.getPrintUnqual - dflags <- getDynFlags - sdocs <- mapM (infoThing allInfo) (words s) - mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs - -infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc -infoThing allInfo str = do - names <- GHC.parseName str - mb_stuffs <- mapM (GHC.getInfo allInfo) names - let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs) - return $ vcat (intersperse (text "") $ map pprInfo filtered) - - -- Filter out names whose parent is also there Good - -- example is '[]', which is both a type and data - -- constructor in the same type -filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs - = filterOut has_parent xs - where - all_names = mkNameSet (map (getName . get_thing) xs) - has_parent x = case tyThingParent_maybe (get_thing x) of - Just p -> getName p `elemNameSet` all_names - Nothing -> False - -pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc -pprInfo (thing, fixity, cls_insts, fam_insts) - = pprTyThingInContextLoc thing - $$ show_fixity - $$ vcat (map GHC.pprInstance cls_insts) - $$ vcat (map GHC.pprFamInst fam_insts) - where - show_fixity - | fixity == GHC.defaultFixity = empty - | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing) - ------------------------------------------------------------------------------ --- :main - -runMain :: String -> GHCi () -runMain s = case toArgs s of - Left err -> liftIO (hPutStrLn stderr err) - Right args -> - do dflags <- getDynFlags - let main = fromMaybe "main" (mainFunIs dflags) - -- Wrap the main function in 'void' to discard its value instead - -- of printing it (#9086). See Haskell 2010 report Chapter 5. - doWithArgs args $ "Control.Monad.void (" ++ main ++ ")" - ------------------------------------------------------------------------------ --- :run - -runRun :: String -> GHCi () -runRun s = case toCmdArgs s of - Left err -> liftIO (hPutStrLn stderr err) - Right (cmd, args) -> doWithArgs args cmd - -doWithArgs :: [String] -> String -> GHCi () -doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ - show args ++ " (" ++ cmd ++ ")"] - ------------------------------------------------------------------------------ --- :cd - -changeDirectory :: String -> InputT GHCi () -changeDirectory "" = do - -- :cd on its own changes to the user's home directory - either_dir <- liftIO $ tryIO getHomeDirectory - case either_dir of - Left _e -> return () - Right dir -> changeDirectory dir -changeDirectory dir = do - graph <- GHC.getModuleGraph - when (not (null graph)) $ - 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 [] - GHC.workingDirectoryChanged - dir' <- expandPath dir - liftIO $ setCurrentDirectory dir' - dflags <- getDynFlags - -- With -fexternal-interpreter, we have to change the directory of the subprocess too. - -- (this gives consistent behaviour with and without -fexternal-interpreter) - when (gopt Opt_ExternalInterpreter dflags) $ - lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir'] - -trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag -trySuccess act = - handleSourceError (\e -> do GHC.printException e - return Failed) $ do - act - ------------------------------------------------------------------------------ --- :edit - -editFile :: String -> InputT GHCi () -editFile str = - do file <- if null str then lift chooseEditFile else expandPath str - st <- getGHCiState - errs <- liftIO $ readIORef $ lastErrorLocations st - let cmd = editor st - when (null cmd) - $ throwGhcException (CmdLineError "editor not set, use :set editor") - lineOpt <- liftIO $ do - let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2) - `catchIO` (\_ -> return False) - - curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs - return $ case curFileErrs of - (_, line):_ -> " +" ++ show line - _ -> "" - let cmdArgs = ' ':(file ++ lineOpt) - code <- liftIO $ system (cmd ++ cmdArgs) - - when (code == ExitSuccess) - $ reloadModule "" - --- The user didn't specify a file so we pick one for them. --- Our strategy is to pick the first module that failed to load, --- or otherwise the first target. --- --- XXX: Can we figure out what happened if the depndecy analysis fails --- (e.g., because the porgrammeer mistyped the name of a module)? --- XXX: Can we figure out the location of an error to pass to the editor? --- 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 = - do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x - - graph <- GHC.getModuleGraph - failed_graph <- filterM hasFailed graph - let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing - pick xs = case xs of - x : _ -> GHC.ml_hs_file (GHC.ms_location x) - _ -> Nothing - - case pick (order failed_graph) of - Just file -> return file - Nothing -> - do targets <- GHC.getTargets - case msum (map fromTarget targets) of - Just file -> return file - Nothing -> throwGhcException (CmdLineError "No files to edit.") - - where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f - fromTarget _ = Nothing -- when would we get a module target? - - ------------------------------------------------------------------------------ --- :def - -defineMacro :: Bool{-overwrite-} -> String -> GHCi () -defineMacro _ (':':_) = - liftIO $ putStrLn "macro name cannot start with a colon" -defineMacro overwrite s = do - let (macro_name, definition) = break isSpace s - macros <- ghci_macros <$> getGHCiState - let defined = map cmdName macros - if null macro_name - then if null defined - then liftIO $ putStrLn "no macros defined" - else liftIO $ putStr ("the following macros are defined:\n" ++ - unlines defined) - else do - if (not overwrite && macro_name `elem` defined) - then throwGhcException (CmdLineError - ("macro '" ++ macro_name ++ "' is already defined")) - else do - - -- compile the expression - handleSourceError GHC.printException $ do - step <- getGhciStepIO - expr <- GHC.parseExpr definition - -- > ghciStepIO . definition :: String -> IO String - let stringTy = nlHsTyVar stringTy_RDR - ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy - body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) - `mkHsApp` (nlHsPar expr) - tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) - new_expr = L (getLoc expr) $ ExprWithTySig body tySig - hv <- GHC.compileParsedExprRemote new_expr - - let newCmd = Command { cmdName = macro_name - , cmdAction = lift . runMacro hv - , cmdHidden = False - , cmdCompletionFunc = noCompletion - } - - -- later defined macros have precedence - modifyGHCiState $ \s -> - 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 fun s = do - hsc_env <- GHC.getSession - str <- liftIO $ evalStringToIOString hsc_env fun s - enqueueCommands (lines str) - return False - - ------------------------------------------------------------------------------ --- :undef - -undefineMacro :: String -> GHCi () -undefineMacro str = mapM_ undef (words str) - where undef macro_name = do - cmds <- ghci_macros <$> getGHCiState - if (macro_name `notElem` map cmdName cmds) - then throwGhcException (CmdLineError - ("macro '" ++ macro_name ++ "' is not defined")) - else do - -- This is a tad racy but really, it's a shell - modifyGHCiState $ \s -> - s { ghci_macros = filter ((/= macro_name) . cmdName) - (ghci_macros s) } - - ------------------------------------------------------------------------------ --- :cmd - -cmdCmd :: String -> GHCi () -cmdCmd str = handleSourceError GHC.printException $ do - step <- getGhciStepIO - expr <- GHC.parseExpr str - -- > ghciStepIO str :: IO String - let new_expr = step `mkHsApp` expr - hv <- GHC.compileParsedExprRemote new_expr - - hsc_env <- GHC.getSession - cmds <- liftIO $ evalString hsc_env hv - enqueueCommands (lines cmds) - --- | Generate a typed ghciStepIO expression --- @ghciStepIO :: Ty String -> IO String@. -getGhciStepIO :: GHCi (LHsExpr RdrName) -getGhciStepIO = do - ghciTyConName <- GHC.getGHCiMonad - let stringTy = nlHsTyVar stringTy_RDR - ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy - ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy - body = nlHsVar (getRdrName ghciStepIoMName) - tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) - return $ noLoc $ ExprWithTySig body tySig - ------------------------------------------------------------------------------ --- :check - -checkModule :: String -> InputT GHCi () -checkModule m = do - let modl = GHC.mkModuleName m - ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do - r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl - dflags <- getDynFlags - liftIO $ putStrLn $ showSDoc dflags $ - case GHC.moduleInfo r of - cm | Just scope <- GHC.modInfoTopLevelScope cm -> - let - (loc, glob) = ASSERT( all isExternalName scope ) - partition ((== modl) . GHC.moduleName . GHC.nameModule) scope - in - (text "global names: " <+> ppr glob) $$ - (text "local names: " <+> ppr loc) - _ -> empty - return True - afterLoad (successIf ok) False - - ------------------------------------------------------------------------------ --- :load, :add, :reload - --- | 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 load = - gbracket - (do - -- Force originalFlags to avoid leaking the associated HscEnv - !originalFlags <- getDynFlags - void $ GHC.setProgramDynFlags $ - setGeneralFlag' Opt_DeferTypeErrors originalFlags - return originalFlags) - (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags) - (\_ -> load) - -loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag -loadModule fs = timeIt (const Nothing) (loadModule' fs) - --- | @:load@ command -loadModule_ :: [FilePath] -> InputT GHCi () -loadModule_ fs = void $ loadModule (zip fs (repeat Nothing)) - -loadModuleDefer :: [FilePath] -> InputT GHCi () -loadModuleDefer = wrapDeferTypeErrors . loadModule_ - -loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag -loadModule' files = do - let (filenames, phases) = unzip files - exp_filenames <- mapM expandPath filenames - let files' = zip exp_filenames phases - targets <- mapM (uncurry GHC.guessTarget) files' - - -- NOTE: we used to do the dependency anal first, so that if it - -- fails we didn't throw away the current set of modules. This would - -- require some re-working of the GHC interface, so we'll leave it - -- as a ToDo for now. - - -- unload first - _ <- GHC.abandonAll - lift discardActiveBreakPoints - GHC.setTargets [] - _ <- GHC.load LoadAllTargets - - GHC.setTargets targets - doLoadAndCollectInfo False LoadAllTargets - --- | @:add@ command -addModule :: [FilePath] -> InputT GHCi () -addModule files = do - lift revertCAFs -- always revert CAFs on load/add. - files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing) files' - -- remove old targets with the same id; e.g. for :add *M - mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] - mapM_ GHC.addTarget targets - _ <- doLoadAndCollectInfo False LoadAllTargets - return () - --- | @:reload@ command -reloadModule :: String -> InputT GHCi () -reloadModule m = void $ doLoadAndCollectInfo True loadTargets - where - loadTargets | null m = LoadAllTargets - | otherwise = LoadUpTo (GHC.mkModuleName m) - -reloadModuleDefer :: String -> InputT GHCi () -reloadModuleDefer = wrapDeferTypeErrors . reloadModule - --- | Load/compile targets and (optionally) collect module-info --- --- This collects the necessary SrcSpan annotated type information (via --- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@, --- and @:uses@ commands. --- --- Meta-info collection is not enabled by default and needs to be --- enabled explicitly via @:set +c@. The reason is that collecting --- the type-information for all sub-spans can be quite expensive, and --- 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 retain_context howmuch = do - doCollectInfo <- lift (isOptionSet CollectInfo) - - doLoad retain_context howmuch >>= \case - Succeeded | doCollectInfo -> do - loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name - v <- mod_infos <$> getGHCiState - !newInfos <- collectInfo v loaded - modifyGHCiState (\st -> st { mod_infos = newInfos }) - return Succeeded - flag -> return flag - -doLoad :: Bool -> LoadHowMuch -> InputT GHCi 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 - - lift 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. - gbracket (liftIO $ do hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering) - (\_ -> - liftIO $ do hSetBuffering stdout NoBuffering - hSetBuffering stderr NoBuffering) $ \_ -> do - ok <- trySuccess $ GHC.load howmuch - afterLoad ok retain_context - return ok - - -afterLoad :: SuccessFlag - -> Bool -- keep the remembered_ctx, as far as possible (:reload) - -> InputT GHCi () -afterLoad ok retain_context = do - lift revertCAFs -- always revert CAFs on load. - lift discardTickArrays - loaded_mods <- getLoadedModules - modulesLoadedMsg ok loaded_mods - lift $ setContextAfterLoad retain_context loaded_mods - -setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad keep_ctxt [] = do - setContextKeepingPackageModules keep_ctxt [] -setContextAfterLoad keep_ctxt ms = do - -- load a target if one is available, otherwise load the topmost module. - targets <- GHC.getTargets - case [ m | Just m <- map (findTarget ms) targets ] of - [] -> - let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in - load_this (last graph') - (m:_) -> - load_this m - where - findTarget mds t - = case filter (`matches` t) mds of - [] -> Nothing - (m:_) -> Just m - - summary `matches` Target (TargetModule m) _ _ - = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ _ - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' - _ `matches` _ - = False - - load_this summary | m <- GHC.ms_mod summary = do - is_interp <- GHC.moduleIsInterpreted m - dflags <- getDynFlags - let star_ok = is_interp && not (safeLanguageOn dflags) - -- We import the module with a * iff - -- - it is interpreted, and - -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] - | otherwise = [mkIIDecl (GHC.moduleName m)] - setContextKeepingPackageModules keep_ctxt new_ctx - - --- | 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 () - -setContextKeepingPackageModules keep_ctx trans_ctx = do - - st <- getGHCiState - let rem_ctx = remembered_ctx st - new_rem_ctx <- if keep_ctx then return rem_ctx - else keepPackageImports rem_ctx - setGHCiState st{ remembered_ctx = new_rem_ctx, - transient_ctx = filterSubsumed new_rem_ctx trans_ctx } - setGHCContextFromGHCiState - --- | Filters a list of 'InteractiveImport', clearing out any home package --- 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 = filterM is_pkg_import - where - is_pkg_import :: InteractiveImport -> GHCi Bool - is_pkg_import (IIModule _) = return False - is_pkg_import (IIDecl d) - = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d) - case e :: Either SomeException Module of - Left _ -> return False - Right m -> return (not (isHomeModule m)) - where - mod_name = unLoc (ideclName d) - - -modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi () -modulesLoadedMsg ok mods = do - dflags <- getDynFlags - unqual <- GHC.getPrintUnqual - - msg <- if gopt Opt_ShowLoadedModules dflags - then do - mod_names <- mapM mod_name mods - let mod_commas - | null mods = text "none." - | otherwise = hsep (punctuate comma mod_names) <> text "." - return $ status <> text ", modules loaded:" <+> mod_commas - else do - return $ status <> text "," - <+> speakNOf (length mods) (text "module") <+> "loaded." - - when (verbosity dflags > 0) $ - liftIO $ putStrLn $ showSDocForUser dflags unqual msg - where - status = case ok of - Failed -> text "Failed" - Succeeded -> text "Ok" - - mod_name mod = do - is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod - return $ if is_interpreted - then ppr (GHC.ms_mod mod) - else ppr (GHC.ms_mod mod) - <+> parens (text $ normalise $ msObjFilePath mod) - -- Fix #9887 - --- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors --- and printing 'throwE' strings to 'stderr' -runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m () -runExceptGhcMonad act = handleSourceError GHC.printException $ - either handleErr pure =<< - runExceptT act - where - handleErr sdoc = do - dflags <- getDynFlags - liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc - --- | Inverse of 'runExceptT' for \"pure\" computations --- (c.f. 'except' for 'Except') -exceptT :: Applicative m => Either e a -> ExceptT e m a -exceptT = ExceptT . pure - ------------------------------------------------------------------------------ --- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver. - -typeOfExpr :: String -> InputT GHCi () -typeOfExpr str = handleSourceError GHC.printException $ do - let (mode, expr_str) = case break isSpace str of - ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest) - ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest) - _ -> (GHC.TM_Inst, str) - ty <- GHC.exprType mode expr_str - printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)] - ------------------------------------------------------------------------------ --- | @:type-at@ command - -typeAtCmd :: String -> InputT GHCi () -typeAtCmd str = runExceptGhcMonad $ do - (span',sample) <- exceptT $ parseSpanArg str - infos <- mod_infos <$> getGHCiState - (info, ty) <- findType infos span' sample - lift $ printForUserModInfo (modinfoInfo info) - (sep [text sample,nest 2 (dcolon <+> ppr ty)]) - ------------------------------------------------------------------------------ --- | @:uses@ command - -usesCmd :: String -> InputT GHCi () -usesCmd str = runExceptGhcMonad $ do - (span',sample) <- exceptT $ parseSpanArg str - infos <- mod_infos <$> getGHCiState - uses <- findNameUses infos span' sample - forM_ uses (liftIO . putStrLn . showSrcSpan) - ------------------------------------------------------------------------------ --- | @:loc-at@ command - -locAtCmd :: String -> InputT GHCi () -locAtCmd str = runExceptGhcMonad $ do - (span',sample) <- exceptT $ parseSpanArg str - infos <- mod_infos <$> getGHCiState - (_,_,sp) <- findLoc infos span' sample - liftIO . putStrLn . showSrcSpan $ sp - ------------------------------------------------------------------------------ --- | @:all-types@ command - -allTypesCmd :: String -> InputT GHCi () -allTypesCmd _ = runExceptGhcMonad $ do - infos <- mod_infos <$> getGHCiState - forM_ (M.elems infos) $ \mi -> - forM_ (modinfoSpans mi) (lift . printSpan) - where - printSpan span' - | Just ty <- spaninfoType span' = do - df <- getDynFlags - let tyInfo = unwords . words $ - showSDocForUser df alwaysQualify (pprTypeForUser ty) - liftIO . putStrLn $ - showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo - | otherwise = return () - ------------------------------------------------------------------------------ --- Helpers for locAtCmd/typeAtCmd/usesCmd - --- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string> -parseSpanArg :: String -> Either SDoc (RealSrcSpan,String) -parseSpanArg s = do - (fp,s0) <- readAsString (skipWs s) - s0' <- skipWs1 s0 - (sl,s1) <- readAsInt s0' - s1' <- skipWs1 s1 - (sc,s2) <- readAsInt s1' - s2' <- skipWs1 s2 - (el,s3) <- readAsInt s2' - s3' <- skipWs1 s3 - (ec,s4) <- readAsInt s3' - - trailer <- case s4 of - [] -> Right "" - _ -> skipWs1 s4 - - let fs = mkFastString fp - span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc) - (mkRealSrcLoc fs el ec) - - return (span',trailer) - where - readAsInt :: String -> Either SDoc (Int,String) - readAsInt "" = Left "Premature end of string while expecting Int" - readAsInt s0 = case reads s0 of - [s_rest] -> Right s_rest - _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int") - - readAsString :: String -> Either SDoc (String,String) - readAsString s0 - | '"':_ <- s0 = case reads s0 of - [s_rest] -> Right s_rest - _ -> leftRes - | s_rest@(_:_,_) <- breakWs s0 = Right s_rest - | otherwise = leftRes - where - leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String") - - skipWs1 :: String -> Either SDoc String - skipWs1 (c:cs) | isWs c = Right (skipWs cs) - skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0)) - - isWs = (`elem` [' ','\t']) - skipWs = dropWhile isWs - breakWs = break isWs - - --- | Pretty-print \"real\" 'SrcSpan's as --- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@ --- while simply unpacking 'UnhelpfulSpan's -showSrcSpan :: SrcSpan -> String -showSrcSpan (UnhelpfulSpan s) = unpackFS s -showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn - --- | Variant of 'showSrcSpan' for 'RealSrcSpan's -showRealSrcSpan :: RealSrcSpan -> String -showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc - , ")-(", show el, ",", show ec, ")" - ] - where - fp = unpackFS (srcSpanFile spn) - sl = srcSpanStartLine spn - sc = srcSpanStartCol spn - el = srcSpanEndLine spn - ec = srcSpanEndCol spn - ------------------------------------------------------------------------------ --- | @:kind@ command - -kindOfType :: Bool -> String -> InputT GHCi () -kindOfType norm str = handleSourceError GHC.printException $ do - (ty, kind) <- GHC.typeKind norm str - printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind - , ppWhen norm $ equals <+> pprTypeForUser ty ] - ------------------------------------------------------------------------------ --- :quit - -quit :: String -> InputT GHCi Bool -quit _ = return True - - ------------------------------------------------------------------------------ --- :script - --- running a script file #1363 - -scriptCmd :: String -> InputT GHCi () -scriptCmd ws = do - case words ws of - [s] -> runScript s - _ -> throwGhcException (CmdLineError "syntax: :script <filename>") - -runScript :: String -- ^ filename - -> InputT GHCi () -runScript filename = do - filename' <- expandPath filename - either_script <- liftIO $ tryIO (openFile filename' ReadMode) - case either_script of - Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" " - ++(ioeGetErrorString _err)) - Right script -> do - st <- getGHCiState - let prog = progname st - line = line_number st - setGHCiState st{progname=filename',line_number=0} - scriptLoop script - liftIO $ hClose script - new_st <- getGHCiState - setGHCiState new_st{progname=prog,line_number=line} - where scriptLoop script = do - res <- runOneCommand handler $ fileLoop script - case res of - Nothing -> return () - Just s -> if s - then scriptLoop script - else return () - ------------------------------------------------------------------------------ --- :issafe - --- Displaying Safe Haskell properties of a module - -isSafeCmd :: String -> InputT GHCi () -isSafeCmd m = - case words m of - [s] | looksLikeModuleName s -> do - md <- lift $ lookupModule s - isSafeModule md - [] -> do md <- guessCurrentModule "issafe" - isSafeModule md - _ -> throwGhcException (CmdLineError "syntax: :issafe <module>") - -isSafeModule :: Module -> InputT GHCi () -isSafeModule m = do - mb_mod_info <- GHC.getModuleInfo m - when (isNothing mb_mod_info) - (throwGhcException $ CmdLineError $ "unknown module: " ++ mname) - - dflags <- getDynFlags - let iface = GHC.modInfoIface $ fromJust mb_mod_info - when (isNothing iface) - (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++ - (GHC.moduleNameString $ GHC.moduleName m)) - - (msafe, pkgs) <- GHC.moduleTrustReqs m - let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface - pkg = if packageTrusted dflags m then "trusted" else "untrusted" - (good, bad) = tallyPkgs dflags pkgs - - -- print info to user... - liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" - liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) - (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of - True -> liftIO $ putStrLn $ mname ++ " is trusted!" - False -> do - when (not $ null bad) - (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) - liftIO $ putStrLn $ mname ++ " is NOT trusted!" - - where - mname = GHC.moduleNameString $ GHC.moduleName m - - packageTrusted dflags md - | thisPackage dflags == moduleUnitId md = True - | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md) - - tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps - where part pkg = trusted $ getInstalledPackageDetails dflags pkg - ------------------------------------------------------------------------------ --- :browse - --- Browsing a module's contents - -browseCmd :: Bool -> String -> InputT GHCi () -browseCmd bang m = - case words m of - ['*':s] | looksLikeModuleName s -> do - md <- lift $ wantInterpretedModule s - browseModule bang md False - [s] | looksLikeModuleName s -> do - md <- lift $ 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 --- Guess which module the user wants to browse. Pick --- modules that are interpreted first. The most --- recently-added module occurs last, it seems. -guessCurrentModule cmd - = do imports <- GHC.getContext - when (null imports) $ throwGhcException $ - CmdLineError (':' : cmd ++ ": no current module") - case (head imports) of - IIModule m -> GHC.findModule m Nothing - IIDecl d -> GHC.findModule (unLoc (ideclName d)) - (fmap sl_fs $ ideclPkgQual d) - --- without bang, show items in context of their parents and omit children --- 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 bang modl exports_only = do - -- :browse reports qualifiers wrt current context - unqual <- GHC.getPrintUnqual - - mb_mod_info <- GHC.getModuleInfo modl - case mb_mod_info of - Nothing -> throwGhcException (CmdLineError ("unknown module: " ++ - GHC.moduleNameString (GHC.moduleName modl))) - Just mod_info -> do - dflags <- getDynFlags - let names - | exports_only = GHC.modInfoExports mod_info - | otherwise = GHC.modInfoTopLevelScope mod_info - `orElse` [] - - -- sort alphabetically name, but putting locally-defined - -- identifiers first. We would like to improve this; see #1799. - sorted_names = loc_sort local ++ occ_sort external - where - (local,external) = ASSERT( all isExternalName names ) - partition ((==modl) . nameModule) names - occ_sort = sortBy (compare `on` nameOccName) - -- try to sort by src location. If the first name in our list - -- has a good source location, then they all should. - loc_sort ns - | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n) - = sortBy (compare `on` nameSrcSpan) ns - | otherwise - = occ_sort ns - - mb_things <- mapM GHC.lookupName sorted_names - let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) - - rdr_env <- GHC.getGRE - - let things | bang = catMaybes mb_things - | otherwise = filtered_things - pretty | bang = pprTyThing showToHeader - | otherwise = pprTyThingInContext showToHeader - - labels [] = text "-- not currently imported" - labels l = text $ intercalate "\n" $ map qualifier l - - qualifier :: Maybe [ModuleName] -> String - qualifier = maybe "-- defined locally" - (("-- imported via "++) . intercalate ", " - . map GHC.moduleNameString) - importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env - - modNames :: [[Maybe [ModuleName]]] - modNames = map (importInfo . GHC.getName) things - - -- annotate groups of imports with their import modules - -- the default ordering is somewhat arbitrary, so we group - -- by header and sort groups; the names themselves should - -- really come in order of source appearance.. (trac #1799) - annotate mts = concatMap (\(m,ts)->labels m:ts) - $ sortBy cmpQualifiers $ grp mts - where cmpQualifiers = - compare `on` (map (fmap (map moduleNameFS)) . fst) - grp [] = [] - grp mts@((m,_):_) = (m,map snd g) : grp ng - where (g,ng) = partition ((==m).fst) mts - - let prettyThings, prettyThings' :: [SDoc] - prettyThings = map pretty things - prettyThings' | bang = annotate $ zip modNames prettyThings - | otherwise = prettyThings - liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings') - -- ToDo: modInfoInstances currently throws an exception for - -- package modules. When it works, we can do this: - -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) - - ------------------------------------------------------------------------------ --- :module - --- Setting the module context. For details on context handling see --- "remembered_ctx" and "transient_ctx" in GhciMonad. - -moduleCmd :: String -> GHCi () -moduleCmd str - | all sensible strs = cmd - | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") - where - (cmd, strs) = - case str of - '+':stuff -> rest addModulesToContext stuff - '-':stuff -> rest remModulesFromContext stuff - stuff -> rest setContext stuff - - rest op stuff = (op as bs, stuffs) - where (as,bs) = partitionWith starred stuffs - stuffs = words stuff - - sensible ('*':m) = looksLikeModuleName m - sensible m = looksLikeModuleName m - - starred ('*':m) = Left (GHC.mkModuleName m) - starred m = Right (GHC.mkModuleName m) - - --- ----------------------------------------------------------------------------- --- Four ways to manipulate the context: --- (a) :module +<stuff>: addModulesToContext --- (b) :module -<stuff>: remModulesFromContext --- (c) :module <stuff>: setContext --- (d) import <module>...: addImportToContext - -addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi () -addModulesToContext starred unstarred = restoreContextOnFailure $ do - addModulesToContext_ starred unstarred - -addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi () -addModulesToContext_ starred unstarred = do - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) - setGHCContextFromGHCiState - -remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi () -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 - -- modules, we don't want GHC to silently put them back in again. - mapM_ rm (starred ++ unstarred) - setGHCContextFromGHCiState - where - rm :: ModuleName -> GHCi () - rm str = do - m <- moduleName <$> lookupModuleName str - let filt = filter ((/=) m . iiModuleName) - modifyGHCiState $ \st -> - st { remembered_ctx = filt (remembered_ctx st) - , transient_ctx = filt (transient_ctx st) } - -setContext :: [ModuleName] -> [ModuleName] -> GHCi () -setContext starred unstarred = restoreContextOnFailure $ do - modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] } - -- delete the transient context - addModulesToContext_ starred unstarred - -addImportToContext :: String -> GHCi () -addImportToContext str = restoreContextOnFailure $ do - idecl <- GHC.parseImportDecl str - addII (IIDecl idecl) -- #5836 - setGHCContextFromGHCiState - --- Util used by addImportToContext and addModulesToContext -addII :: InteractiveImport -> GHCi () -addII iidecl = do - checkAdd iidecl - modifyGHCiState $ \st -> - st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st) - , transient_ctx = filter (not . (iidecl `iiSubsumes`)) - (transient_ctx st) - } - --- Sometimes we can't tell whether an import is valid or not until --- we finally call 'GHC.setContext'. e.g. --- --- import System.IO (foo) --- --- will fail because System.IO does not export foo. In this case we --- don't want to store the import in the context permanently, so we --- catch the failure from 'setGHCContextFromGHCiState' and set the --- context back to what it was. --- --- See #6007 --- -restoreContextOnFailure :: GHCi a -> GHCi a -restoreContextOnFailure do_this = do - st <- getGHCiState - let rc = remembered_ctx st; tc = transient_ctx st - do_this `gonException` (modifyGHCiState $ \st' -> - st' { remembered_ctx = rc, transient_ctx = tc }) - --- ----------------------------------------------------------------------------- --- Validate a module that we want to add to the context - -checkAdd :: InteractiveImport -> GHCi () -checkAdd ii = do - dflags <- getDynFlags - let safe = safeLanguageOn dflags - case ii of - IIModule modname - | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> wantInterpretedModuleName modname >> return () - - IIDecl d -> do - let modname = unLoc (ideclName d) - pkgqual = ideclPkgQual d - m <- GHC.lookupModule modname (fmap sl_fs pkgqual) - when safe $ do - t <- GHC.isModuleTrusted m - when (not t) $ throwGhcException $ ProgramError $ "" - --- ----------------------------------------------------------------------------- --- Update the GHC API's view of the context - --- | Sets the GHC context from the GHCi state. The GHC context is --- always set this way, we never modify it incrementally. --- --- We ignore any imports for which the ModuleName does not currently --- exist. This is so that the remembered_ctx can contain imports for --- modules that are not currently loaded, perhaps because we just did --- a :reload and encountered errors. --- --- Prelude is added if not already present in the list. Therefore to --- override the implicit Prelude import you can say 'import Prelude ()' --- at the prompt, just as in Haskell source. --- -setGHCContextFromGHCiState :: GHCi () -setGHCContextFromGHCiState = do - st <- getGHCiState - -- re-use checkAdd to check whether the module is valid. If the - -- module does not exist, we do *not* want to print an error - -- here, we just want to silently keep the module in the context - -- until such time as the module reappears again. So we ignore - -- the actual exception thrown by checkAdd, using tryBool to - -- turn it into a Bool. - iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st) - - prel_iidecls <- getImplicitPreludeImports iidecls - valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls - - extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st)) - - GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls - - -getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport] -getImplicitPreludeImports iidecls = do - dflags <- GHC.getInteractiveDynFlags - -- allow :seti to override -XNoImplicitPrelude - st <- getGHCiState - - -- We add the prelude imports if there are no *-imports, and we also - -- allow each prelude import to be subsumed by another explicit import - -- of the same module. This means that you can override the prelude import - -- with "import Prelude hiding (map)", for example. - let prel_iidecls = - if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls) - then [ IIDecl imp - | imp <- prelude_imports st - , not (any (sameImpModule imp) iidecls) ] - else [] - - return prel_iidecls - --- ----------------------------------------------------------------------------- --- Utils on InteractiveImport - -mkIIModule :: ModuleName -> InteractiveImport -mkIIModule = IIModule - -mkIIDecl :: ModuleName -> InteractiveImport -mkIIDecl = IIDecl . simpleImportDecl - -iiModules :: [InteractiveImport] -> [ModuleName] -iiModules is = [m | IIModule m <- is] - -isIIModule :: InteractiveImport -> Bool -isIIModule (IIModule _) = True -isIIModule _ = False - -iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = m -iiModuleName (IIDecl d) = unLoc (ideclName d) - -preludeModuleName :: ModuleName -preludeModuleName = GHC.mkModuleName "Prelude" - -sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool -sameImpModule _ (IIModule _) = False -- we only care about imports here -sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp) - -addNotSubsumed :: InteractiveImport - -> [InteractiveImport] -> [InteractiveImport] -addNotSubsumed i is - | any (`iiSubsumes` i) is = is - | otherwise = i : filter (not . (i `iiSubsumes`)) is - --- | @filterSubsumed is js@ returns the elements of @js@ not subsumed --- by any of @is@. -filterSubsumed :: [InteractiveImport] -> [InteractiveImport] - -> [InteractiveImport] -filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js - --- | Returns True if the left import subsumes the right one. Doesn't --- need to be 100% accurate, conservatively returning False is fine. --- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in --- plusProv will ensue (#5904)) --- --- Note that an IIModule does not necessarily subsume an IIDecl, --- because e.g. a module might export a name that is only available --- qualified within the module itself. --- --- Note that 'import M' does not necessarily subsume 'import M(foo)', --- because M might not export foo and we want an error to be produced --- in that case. --- -iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool -iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 -iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude - = unLoc (ideclName d1) == unLoc (ideclName d2) - && ideclAs d1 == ideclAs d2 - && (not (ideclQualified d1) || ideclQualified d2) - && (ideclHiding d1 `hidingSubsumes` ideclHiding d2) - where - _ `hidingSubsumes` Just (False,L _ []) = True - Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys) - = all (`elem` xs) ys - h1 `hidingSubsumes` h2 = h1 == h2 -iiSubsumes _ _ = False - - ----------------------------------------------------------------------------- --- :set - --- set options in the interpreter. Syntax is exactly the same as the --- ghc command line, except that certain options aren't available (-C, --- -E etc.) --- --- This is pretty fragile: most options won't work as expected. ToDo: --- figure out which ones & disallow them. - -setCmd :: String -> GHCi () -setCmd "" = showOptions False -setCmd "-a" = showOptions True -setCmd str - = case getCmd str of - Right ("args", rest) -> - case toArgs rest of - Left err -> liftIO (hPutStrLn stderr err) - Right args -> setArgs args - Right ("prog", rest) -> - case toArgs rest of - Right [prog] -> setProg prog - _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") - - Right ("prompt", rest) -> - setPromptString setPrompt (dropWhile isSpace rest) - "syntax: set prompt <string>" - Right ("prompt-function", rest) -> - setPromptFunc setPrompt $ dropWhile isSpace rest - Right ("prompt-cont", rest) -> - setPromptString setPromptCont (dropWhile isSpace rest) - "syntax: :set prompt-cont <string>" - Right ("prompt-cont-function", rest) -> - setPromptFunc setPromptCont $ dropWhile isSpace rest - - Right ("editor", rest) -> setEditor $ dropWhile isSpace rest - Right ("stop", rest) -> setStop $ dropWhile isSpace rest - _ -> case toArgs str of - Left err -> liftIO (hPutStrLn stderr err) - Right wds -> setOptions wds - -setiCmd :: String -> GHCi () -setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False -setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True -setiCmd str = - case toArgs str of - Left err -> liftIO (hPutStrLn stderr err) - Right wds -> newDynFlags True wds - -showOptions :: Bool -> GHCi () -showOptions show_all - = do st <- getGHCiState - dflags <- getDynFlags - let opts = options st - liftIO $ putStrLn (showSDoc dflags ( - text "options currently set: " <> - if null opts - then text "none." - else hsep (map (\o -> char '+' <> text (optToStr o)) opts) - )) - getDynFlags >>= liftIO . showDynFlags show_all - - -showDynFlags :: Bool -> DynFlags -> IO () -showDynFlags show_all dflags = do - showLanguages' show_all dflags - putStrLn $ showSDoc dflags $ - text "GHCi-specific dynamic flag settings:" $$ - nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags)) - putStrLn $ showSDoc dflags $ - text "other dynamic, non-language, flag settings:" $$ - nest 2 (vcat (map (setting "-f" "-fno-" gopt) others)) - putStrLn $ showSDoc dflags $ - text "warning settings:" $$ - nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags)) - where - setting prefix noPrefix test flag - | quiet = empty - | is_on = text prefix <> text name - | otherwise = text noPrefix <> text name - where name = flagSpecName flag - f = flagSpecFlag flag - is_on = test f dflags - quiet = not show_all && test f default_dflags == is_on - - default_dflags = defaultDynFlags (settings dflags) - - (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs) - DynFlags.fFlags - flgs = [ Opt_PrintExplicitForalls - , Opt_PrintExplicitKinds - , Opt_PrintUnicodeSyntax - , Opt_PrintBindResult - , Opt_BreakOnException - , Opt_BreakOnError - , Opt_PrintEvldWithShow - ] - -setArgs, setOptions :: [String] -> GHCi () -setProg, setEditor, setStop :: String -> GHCi () - -setArgs args = do - st <- getGHCiState - wrapper <- mkEvalWrapper (progname st) args - setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper } - -setProg prog = do - st <- getGHCiState - wrapper <- mkEvalWrapper prog (GhciMonad.args st) - setGHCiState st { progname = prog, evalWrapper = wrapper } - -setEditor cmd = modifyGHCiState (\st -> st { editor = cmd }) - -setStop str@(c:_) | isDigit c - = do let (nm_str,rest) = break (not.isDigit) str - nm = read nm_str - st <- getGHCiState - let old_breaks = breaks st - if all ((/= nm) . fst) old_breaks - then printForUser (text "Breakpoint" <+> ppr nm <+> - text "does not exist") - else do - let new_breaks = map fn old_breaks - fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest }) - | otherwise = (i,loc) - setGHCiState st{ breaks = new_breaks } -setStop cmd = modifyGHCiState (\st -> st { stop = cmd }) - -setPrompt :: PromptFunction -> GHCi () -setPrompt v = modifyGHCiState (\st -> st {prompt = v}) - -setPromptCont :: PromptFunction -> GHCi () -setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v}) - -setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi () -setPromptFunc fSetPrompt s = do - -- We explicitly annotate the type of the expression to ensure - -- that unsafeCoerce# is passed the exact type necessary rather - -- than a more general one - let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String" - (HValue funValue) <- GHC.compileExpr exprStr - fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue) - where - convertToPromptFunction :: ([String] -> Int -> IO String) - -> PromptFunction - convertToPromptFunction func = (\mods line -> liftIO $ - liftM text (func mods line)) - -setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi () -setPromptString fSetPrompt value err = do - if null value - then liftIO $ hPutStrLn stderr $ err - else case value of - ('\"':_) -> - case reads value of - [(value', xs)] | all isSpace xs -> - setParsedPromptString fSetPrompt value' - _ -> liftIO $ hPutStrLn stderr - "Can't parse prompt string. Use Haskell syntax." - _ -> - setParsedPromptString fSetPrompt value - -setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi () -setParsedPromptString fSetPrompt s = do - case (checkPromptStringForErrors s) of - Just err -> - liftIO $ hPutStrLn stderr err - Nothing -> - fSetPrompt $ generatePromptFunctionFromString s - -setOptions wds = - do -- first, deal with the GHCi opts (+s, +t, etc.) - let (plus_opts, minus_opts) = partitionWith isPlus wds - mapM_ setOpt plus_opts - -- then, dynamic flags - when (not (null minus_opts)) $ newDynFlags False minus_opts - -newDynFlags :: Bool -> [String] -> GHCi () -newDynFlags interactive_only minus_opts = do - let lopts = map noLoc minus_opts - - idflags0 <- GHC.getInteractiveDynFlags - (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts - - liftIO $ handleFlagWarnings idflags1 warns - when (not $ null leftovers) - (throwGhcException . CmdLineError - $ "Some flags have not been recognized: " - ++ (concat . intersperse ", " $ map unLoc leftovers)) - - when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do - liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" - GHC.setInteractiveDynFlags idflags1 - installInteractivePrint (interactivePrint idflags1) False - - dflags0 <- getDynFlags - when (not interactive_only) $ do - (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts - new_pkgs <- GHC.setProgramDynFlags dflags1 - - -- if the package flags changed, reset the context and link - -- the new packages. - hsc_env <- GHC.getSession - let dflags2 = hsc_dflags hsc_env - when (packageFlagsChanged dflags2 dflags0) $ do - when (verbosity dflags2 > 0) $ - liftIO . putStrLn $ - "package flags have changed, resetting and loading new packages..." - GHC.setTargets [] - _ <- GHC.load LoadAllTargets - liftIO $ linkPackages hsc_env new_pkgs - -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False [] - -- and copy the package state to the interactive DynFlags - idflags <- GHC.getInteractiveDynFlags - GHC.setInteractiveDynFlags - idflags{ pkgState = pkgState dflags2 - , pkgDatabase = pkgDatabase dflags2 - , packageFlags = packageFlags dflags2 } - - let ld0length = length $ ldInputs dflags0 - fmrk0length = length $ cmdlineFrameworks dflags0 - - newLdInputs = drop ld0length (ldInputs dflags2) - newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) - - hsc_env' = hsc_env { hsc_dflags = - dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks } } - - when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ linkCmdLineLibs hsc_env' - - return () - - -unsetOptions :: String -> GHCi () -unsetOptions str - = -- first, deal with the GHCi opts (+s, +t, etc.) - let opts = words str - (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partitionWith isPlus rest1 - (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 - - defaulters = - [ ("args" , setArgs default_args) - , ("prog" , setProg default_progname) - , ("prompt" , setPrompt default_prompt) - , ("prompt-cont", setPromptCont default_prompt_cont) - , ("editor" , liftIO findEditor >>= setEditor) - , ("stop" , setStop default_stop) - ] - - no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag ('-':'X':rest) = return ("-XNo" ++ rest) - no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f)) - - in if (not (null rest3)) - then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'")) - else do - mapM_ (fromJust.flip lookup defaulters) other_opts - - mapM_ unsetOpt plus_opts - - no_flags <- mapM no_flag minus_opts - when (not (null no_flags)) $ newDynFlags False no_flags - -isMinus :: String -> Bool -isMinus ('-':_) = True -isMinus _ = False - -isPlus :: String -> Either String String -isPlus ('+':opt) = Left opt -isPlus other = Right other - -setOpt, unsetOpt :: String -> GHCi () - -setOpt str - = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> setOption o - -unsetOpt str - = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> unsetOption o - -strToGHCiOpt :: String -> (Maybe GHCiOption) -strToGHCiOpt "m" = Just Multiline -strToGHCiOpt "s" = Just ShowTiming -strToGHCiOpt "t" = Just ShowType -strToGHCiOpt "r" = Just RevertCAFs -strToGHCiOpt "c" = Just CollectInfo -strToGHCiOpt _ = Nothing - -optToStr :: GHCiOption -> String -optToStr Multiline = "m" -optToStr ShowTiming = "s" -optToStr ShowType = "t" -optToStr RevertCAFs = "r" -optToStr CollectInfo = "c" - - --- --------------------------------------------------------------------------- --- :show - -showCmd :: String -> GHCi () -showCmd "" = showOptions False -showCmd "-a" = showOptions True -showCmd str = do - st <- getGHCiState - dflags <- getDynFlags - - let lookupCmd :: String -> Maybe (GHCi ()) - lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds - - -- (show in help?, command name, action) - action :: String -> GHCi () -> (Bool, String, GHCi ()) - action name m = (True, name, m) - - hidden :: String -> GHCi () -> (Bool, String, GHCi ()) - hidden name m = (False, name, m) - - cmds = - [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st)) - , action "prog" $ liftIO $ putStrLn (show (progname st)) - , action "editor" $ liftIO $ putStrLn (show (editor st)) - , action "stop" $ liftIO $ putStrLn (show (stop st)) - , action "imports" $ showImports - , action "modules" $ showModules - , action "bindings" $ showBindings - , action "linker" $ getDynFlags >>= liftIO . showLinkerState - , action "breaks" $ showBkptTable - , action "context" $ showContext - , action "packages" $ showPackages - , action "paths" $ showPaths - , action "language" $ showLanguages - , hidden "languages" $ showLanguages -- backwards compat - , hidden "lang" $ showLanguages -- useful abbreviation - ] - - case words str of - [w] | Just action <- lookupCmd w -> action - - _ -> let helpCmds = [ text name | (True, name, _) <- cmds ] - in throwGhcException $ CmdLineError $ showSDoc dflags - $ hang (text "syntax:") 4 - $ hang (text ":show") 6 - $ brackets (fsep $ punctuate (text " |") helpCmds) - -showiCmd :: String -> GHCi () -showiCmd str = do - case words str of - ["languages"] -> showiLanguages -- backwards compat - ["language"] -> showiLanguages - ["lang"] -> showiLanguages -- useful abbreviation - _ -> throwGhcException (CmdLineError ("syntax: :showi language")) - -showImports :: GHCi () -showImports = do - st <- getGHCiState - dflags <- getDynFlags - let rem_ctx = reverse (remembered_ctx st) - trans_ctx = transient_ctx st - - show_one (IIModule star_m) - = ":module +*" ++ moduleNameString star_m - show_one (IIDecl imp) = showPpr dflags imp - - prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx) - - let show_prel p = show_one p ++ " -- implicit" - show_extra p = show_one (IIDecl p) ++ " -- fixed" - - trans_comment s = s ++ " -- added automatically" :: String - -- - liftIO $ mapM_ putStrLn (map show_one rem_ctx ++ - map (trans_comment . show_one) trans_ctx ++ - map show_prel prel_iidecls ++ - map show_extra (extra_imports st)) - -showModules :: GHCi () -showModules = do - loaded_mods <- getLoadedModules - -- we want *loaded* modules only, see #1734 - let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m) - mapM_ show_one loaded_mods - -getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] -getLoadedModules = do - graph <- GHC.getModuleGraph - filterM (GHC.isLoaded . GHC.ms_mod_name) graph - -showBindings :: GHCi () -showBindings = do - bindings <- GHC.getBindings - (insts, finsts) <- GHC.getInsts - docs <- mapM makeDoc (reverse bindings) - -- reverse so the new ones come last - let idocs = map GHC.pprInstanceHdr insts - fidocs = map GHC.pprFamInst finsts - mapM_ printForUserPartWay (docs ++ idocs ++ fidocs) - where - makeDoc (AnId i) = pprTypeAndContents i - makeDoc tt = do - mb_stuff <- GHC.getInfo False (getName tt) - return $ maybe (text "") pprTT mb_stuff - - pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc - pprTT (thing, fixity, _cls_insts, _fam_insts) - = pprTyThing showToHeader thing - $$ show_fixity - where - show_fixity - | fixity == GHC.defaultFixity = empty - | otherwise = ppr fixity <+> ppr (GHC.getName thing) - - -printTyThing :: TyThing -> GHCi () -printTyThing tyth = printForUser (pprTyThing showToHeader tyth) - -showBkptTable :: GHCi () -showBkptTable = do - st <- getGHCiState - printForUser $ prettyLocations (breaks st) - -showContext :: GHCi () -showContext = do - resumes <- GHC.getResumeContext - printForUser $ vcat (map pp_resume (reverse resumes)) - where - pp_resume res = - ptext (sLit "--> ") <> text (GHC.resumeStmt res) - $$ nest 2 (pprStopped res) - -pprStopped :: GHC.Resume -> SDoc -pprStopped res = - ptext (sLit "Stopped in") - <+> ((case mb_mod_name of - Nothing -> empty - Just mod_name -> text (moduleNameString mod_name) <> char '.') - <> text (GHC.resumeDecl res)) - <> char ',' <+> ppr (GHC.resumeSpan res) - where - mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res - -showPackages :: GHCi () -showPackages = do - dflags <- getDynFlags - let pkg_flags = packageFlags dflags - liftIO $ putStrLn $ showSDoc dflags $ - text ("active package flags:"++if null pkg_flags then " none" else "") $$ - nest 2 (vcat (map pprFlag pkg_flags)) - -showPaths :: GHCi () -showPaths = do - dflags <- getDynFlags - liftIO $ do - cwd <- getCurrentDirectory - putStrLn $ showSDoc dflags $ - text "current working directory: " $$ - nest 2 (text cwd) - let ipaths = importPaths dflags - putStrLn $ showSDoc dflags $ - text ("module import search paths:"++if null ipaths then " none" else "") $$ - nest 2 (vcat (map text ipaths)) - -showLanguages :: GHCi () -showLanguages = getDynFlags >>= liftIO . showLanguages' False - -showiLanguages :: GHCi () -showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False - -showLanguages' :: Bool -> DynFlags -> IO () -showLanguages' show_all dflags = - putStrLn $ showSDoc dflags $ vcat - [ text "base language is: " <> - case language dflags of - Nothing -> text "Haskell2010" - Just Haskell98 -> text "Haskell98" - Just Haskell2010 -> text "Haskell2010" - , (if show_all then text "all active language options:" - else text "with the following modifiers:") $$ - nest 2 (vcat (map (setting xopt) DynFlags.xFlags)) - ] - where - setting test flag - | quiet = empty - | is_on = text "-X" <> text name - | otherwise = text "-XNo" <> text name - where name = flagSpecName flag - f = flagSpecFlag flag - is_on = test f dflags - quiet = not show_all && test f default_dflags == is_on - - default_dflags = - defaultDynFlags (settings dflags) `lang_set` - case language dflags of - Nothing -> Just Haskell2010 - other -> other - --- ----------------------------------------------------------------------------- --- Completion - -completeCmd :: String -> GHCi () -completeCmd argLine0 = case parseLine argLine0 of - Just ("repl", resultRange, left) -> do - (unusedLine,compls) <- ghciCompleteWord (reverse left,"") - let compls' = takeRange resultRange compls - liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ] - forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do - liftIO $ print r - _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>") - where - parseLine argLine - | null argLine = Nothing - | null rest1 = Nothing - | otherwise = (,,) dom <$> resRange <*> s - where - (dom, rest1) = breakSpace argLine - (rng, rest2) = breakSpace rest1 - resRange | head rest1 == '"' = parseRange "" - | otherwise = parseRange rng - s | head rest1 == '"' = readMaybe rest1 :: Maybe String - | otherwise = readMaybe rest2 - breakSpace = fmap (dropWhile isSpace) . break isSpace - - takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub - - -- syntax: [n-][m] with semantics "drop (n-1) . take m" - parseRange :: String -> Maybe (Maybe Int,Maybe Int) - parseRange s = case span isDigit s of - (_, "") -> - -- upper limit only - Just (Nothing, bndRead s) - (s1, '-' : s2) - | all isDigit s2 -> - Just (bndRead s1, bndRead s2) - _ -> - Nothing - where - bndRead x = if null x then Nothing else Just (read x) - - - -completeGhciCommand, completeMacro, completeIdentifier, completeModule, - completeSetModule, completeSeti, completeShowiOptions, - completeHomeModule, completeSetOptions, completeShowOptions, - completeHomeModuleOrFile, completeExpression - :: CompletionFunc GHCi - --- | Provide completions for last word in a given string. --- --- Takes a tuple of two strings. First string is a reversed line to be --- completed. Second string is likely unused, 'completeCmd' always passes an --- empty string as second item in tuple. -ghciCompleteWord :: CompletionFunc GHCi -ghciCompleteWord line@(left,_) = case firstWord of - -- If given string starts with `:` colon, and there is only one following - -- word then provide REPL command completions. If there is more than one - -- word complete either filename or builtin ghci commands or macros. - ':':cmd | null rest -> completeGhciCommand line - | otherwise -> do - completion <- lookupCompletion cmd - completion line - -- If given string starts with `import` keyword provide module name - -- completions - "import" -> completeModule line - -- otherwise provide identifier completions - _ -> completeExpression line - where - (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left - lookupCompletion ('!':_) = return completeFilename - lookupCompletion c = do - maybe_cmd <- lookupCommand' c - case maybe_cmd of - Just cmd -> return (cmdCompletionFunc cmd) - Nothing -> return completeFilename - -completeGhciCommand = wrapCompleter " " $ \w -> do - macros <- ghci_macros <$> getGHCiState - cmds <- ghci_commands `fmap` getGHCiState - let macro_names = map (':':) . map cmdName $ macros - let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds - let{ candidates = case w of - ':' : ':' : _ -> map (':':) command_names - _ -> nub $ macro_names ++ command_names } - return $ filter (w `isPrefixOf`) candidates - -completeMacro = wrapIdentCompleter $ \w -> do - cmds <- ghci_macros <$> getGHCiState - return (filter (w `isPrefixOf`) (map cmdName cmds)) - -completeIdentifier line@(left, _) = - -- Note: `left` is a reversed input - case left of - (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line - _ -> wrapIdentCompleter complete line - where - complete w = do - rdrs <- GHC.getRdrNamesInScope - dflags <- GHC.getSessionDynFlags - return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs)) - -completeModule = wrapIdentCompleter $ \w -> do - dflags <- GHC.getSessionDynFlags - let pkg_mods = allVisibleModules dflags - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules - return $ filter (w `isPrefixOf`) - $ map (showPpr dflags) $ loaded_mods ++ pkg_mods - -completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do - dflags <- GHC.getSessionDynFlags - modules <- case m of - Just '-' -> do - imports <- GHC.getContext - return $ map iiModuleName imports - _ -> do - let pkg_mods = allVisibleModules dflags - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules - return $ loaded_mods ++ pkg_mods - return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules - -completeHomeModule = wrapIdentCompleter listHomeModules - -listHomeModules :: String -> GHCi [String] -listHomeModules w = do - g <- GHC.getModuleGraph - let home_mods = map GHC.ms_mod_name g - dflags <- getDynFlags - return $ sort $ filter (w `isPrefixOf`) - $ map (showPpr dflags) home_mods - -completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) opts) - where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function": - "prompt-cont-function":"editor":"stop":flagList - flagList = map head $ group $ sort allNonDeprecatedFlags - -completeSeti = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) flagList) - where flagList = map head $ group $ sort allNonDeprecatedFlags - -completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) opts) - where opts = ["args", "prog", "editor", "stop", - "modules", "bindings", "linker", "breaks", - "context", "packages", "paths", "language", "imports"] - -completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) ["language"]) - -completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars - $ unionComplete (fmap (map simpleCompletion) . listHomeModules) - listFiles - -unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] -unionComplete f1 f2 line = do - cs1 <- f1 line - cs2 <- f2 line - return (cs1 ++ cs2) - -wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi -wrapCompleter breakChars fun = completeWord Nothing breakChars - $ fmap (map simpleCompletion . nubSort) . fun - -wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi -wrapIdentCompleter = wrapCompleter word_break_chars - -wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi -wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars - $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest) - where - getModifier = find (`elem` modifChars) - --- | Return a list of visible module names for autocompletion. --- (NB: exposed != visible) -allVisibleModules :: DynFlags -> [ModuleName] -allVisibleModules dflags = listVisibleModuleNames dflags - -completeExpression = completeQuotedWord (Just '\\') "\"" listFiles - completeIdentifier - - --- ----------------------------------------------------------------------------- --- 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 - -stepCmd :: String -> GHCi () -stepCmd arg = withSandboxOnly ":step" $ step arg - where - step [] = doContinue (const True) GHC.SingleStep - step expression = runStmt expression GHC.SingleStep >> return () - -stepLocalCmd :: String -> GHCi () -stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg - where - step expr - | not (null expr) = stepCmd expr - | otherwise = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just loc -> do - Just md <- getCurrentBreakModule - current_toplevel_decl <- enclosingTickSpan md loc - doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep - -stepModuleCmd :: String -> GHCi () -stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg - where - step expr - | not (null expr) = stepCmd expr - | otherwise = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just pan -> do - let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span - doContinue f GHC.SingleStep - --- | Returns the span of the largest tick containing the srcspan given -enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan -enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" -enclosingTickSpan md (RealSrcSpan src) = do - ticks <- getTickArray md - let line = srcSpanStartLine src - ASSERT(inRange (bounds ticks) line) do - let enclosing_spans = [ pan | (_,pan) <- ticks ! line - , realSrcSpanEnd pan >= realSrcSpanEnd src] - return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans - where - -leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering -leftmostLargestRealSrcSpan a b = - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) - -traceCmd :: String -> GHCi () -traceCmd arg - = withSandboxOnly ":trace" $ tr arg - where - tr [] = doContinue (const True) GHC.RunAndLogSteps - tr expression = runStmt expression GHC.RunAndLogSteps >>= saveTraceCmdExecResult >> return () - -continueCmd :: String -> GHCi () -continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion - --- doContinue :: SingleStep -> GHCi () -doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () -doContinue pre step = do - runResult <- resume pre step - saveDoContinueExecResult runResult - _ <- afterRunStmt pre runResult - return () - -abandonCmd :: String -> GHCi () -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 argLine = withSandboxOnly ":delete" $ do - deleteSwitch $ words argLine - where - deleteSwitch :: [String] -> GHCi () - deleteSwitch [] = - liftIO $ putStrLn "The delete command requires at least one argument." - -- delete all break points - deleteSwitch ("*":_rest) = discardActiveBreakPoints - deleteSwitch idents = do - mapM_ deleteOneBreak idents - where - deleteOneBreak :: String -> GHCi () - deleteOneBreak str - | all isDigit str = deleteBreak (read str) - | otherwise = return () - -historyCmd :: String -> GHCi () -historyCmd arg - | null arg = history 20 - | all isDigit arg = history (read arg) - | otherwise = liftIO $ putStrLn "Syntax: :history [num]" - where - history num = do - resumes <- GHC.getResumeContext - case resumes of - [] -> liftIO $ putStrLn "Not stopped at a breakpoint" - (r:_) -> do - let hist = GHC.resumeHistory r - (took,rest) = splitAt num hist - case hist of - [] -> liftIO $ putStrLn $ - "Empty history. Perhaps you forgot to use :trace?" - _ -> do - pans <- mapM GHC.getHistorySpan took - let nums = map (printf "-%-3d:") [(1::Int)..] - names = map GHC.historyEnclosingDecls took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) - (map (bold . hcat . punctuate colon . map text) names) - (map (parens . ppr) pans))) - liftIO $ putStrLn $ if null rest then "<end of history>" else "..." - -bold :: SDoc -> SDoc -bold c | do_bold = text start_bold <> c <> text end_bold - | otherwise = c - -backCmd :: String -> GHCi () -backCmd arg - | null arg = back 1 - | all isDigit arg = back (read arg) - | otherwise = liftIO $ putStrLn "Syntax: :back [num]" - where - back num = withSandboxOnly ":back" $ do - (names, _, pan, _) <- GHC.back num - printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan - printTypeOfNames names - -- run the command set with ":set stop <cmd>" - st <- getGHCiState - enqueueCommands [stop st] - -forwardCmd :: String -> GHCi () -forwardCmd arg - | null arg = forward 1 - | all isDigit arg = forward (read arg) - | otherwise = liftIO $ putStrLn "Syntax: :back [num]" - where - forward num = withSandboxOnly ":forward" $ do - (names, ix, pan, _) <- GHC.forward num - printForUser $ (if (ix == 0) - then ptext (sLit "Stopped at") - else ptext (sLit "Logged breakpoint at")) <+> ppr pan - printTypeOfNames names - -- run the command set with ":set stop <cmd>" - st <- getGHCiState - enqueueCommands [stop st] - --- handle the "break" command -breakCmd :: String -> GHCi () -breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine - -breakSwitch :: [String] -> GHCi () -breakSwitch [] = do - liftIO $ putStrLn "The break command requires at least one argument." -breakSwitch (arg1:rest) - | looksLikeModuleName arg1 && not (null rest) = do - md <- wantInterpretedModule arg1 - breakByModule md rest - | all isDigit arg1 = do - imports <- GHC.getContext - case iiModules imports of - (mn : _) -> do - md <- lookupModuleName mn - breakByModuleLine md (read arg1) rest - [] -> do - liftIO $ putStrLn "No modules are loaded with debugging support." - | otherwise = do -- try parsing it as an identifier - wantNameFromInterpretedModule noCanDo arg1 $ \name -> do - maybe_info <- GHC.getModuleInfo (GHC.nameModule name) - case maybe_info of - Nothing -> noCanDo name (ptext (sLit "cannot get module info")) - Just minf -> - ASSERT( isExternalName name ) - findBreakAndSet (GHC.nameModule name) $ - findBreakForBind name (GHC.modInfoModBreaks minf) - where - noCanDo n why = printForUser $ - text "cannot set breakpoint on " <> ppr n <> text ": " <> why - -breakByModule :: Module -> [String] -> GHCi () -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 md line args - | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line - | [col] <- args, all isDigit col = - findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col) - | otherwise = breakSyntax - -breakSyntax :: a -breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") - -findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi () -findBreakAndSet md lookupTickTree = do - tickArray <- getTickArray md - (breakArray, _) <- getModBreak md - case lookupTickTree tickArray of - [] -> liftIO $ putStrLn $ "No breakpoints found at that location." - some -> mapM_ (breakAt breakArray) some - where - breakAt breakArray (tick, pan) = do - setBreakFlag True breakArray tick - (alreadySet, nm) <- - recordBreak $ BreakLocation - { breakModule = md - , breakLoc = RealSrcSpan pan - , breakTick = tick - , onBreakCmd = "" - } - printForUser $ - text "Breakpoint " <> ppr nm <> - if alreadySet - then text " was already set at " <> ppr pan - else text " activated at " <> ppr pan - --- When a line number is specified, the current policy for choosing --- the best breakpoint is this: --- - the leftmost complete subexpression on the specified line, or --- - the leftmost subexpression starting on the specified line, or --- - the rightmost subexpression enclosing the specified line --- -findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan) -findBreakByLine line arr - | not (inRange (bounds arr) line) = Nothing - | otherwise = - listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus` - listToMaybe (sortBy (compare `on` snd) incomp) `mplus` - listToMaybe (sortBy (flip compare `on` snd) ticks) - where - ticks = arr ! line - - starts_here = [ (ix,pan) | (ix, pan) <- ticks, - GHC.srcSpanStartLine pan == line ] - - (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine pan == line - --- The aim is to find the breakpoints for all the RHSs of the --- equations corresponding to a binding. So we find all breakpoints --- for --- (a) this binder only (not a nested declaration) --- (b) that do not have an enclosing breakpoint -findBreakForBind :: Name -> GHC.ModBreaks -> TickArray - -> [(BreakIndex,RealSrcSpan)] -findBreakForBind name modbreaks _ = filter (not . enclosed) ticks - where - ticks = [ (index, span) - | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks), - n == occNameString (nameOccName name), - RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ] - enclosed (_,sp0) = any subspan ticks - where subspan (_,sp) = sp /= sp0 && - realSrcSpanStart sp <= realSrcSpanStart sp0 && - realSrcSpanEnd sp0 <= realSrcSpanEnd sp - -findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray - -> Maybe (BreakIndex,RealSrcSpan) -findBreakByCoord mb_file (line, col) arr - | not (inRange (bounds arr) line) = Nothing - | otherwise = - listToMaybe (sortBy (flip compare `on` snd) contains ++ - sortBy (compare `on` snd) after_here) - where - ticks = arr ! line - - -- the ticks that span this coordinate - contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col), - is_correct_file pan ] - - is_correct_file pan - | Just f <- mb_file = GHC.srcSpanFile pan == f - | otherwise = True - - after_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine pan == line, - GHC.srcSpanStartCol pan >= col ] - --- For now, use ANSI bold on terminals that we know support it. --- Otherwise, we add a line of carets under the active expression instead. --- In particular, on Windows and when running the testsuite (which sets --- TERM to vt100 for other reasons) we get carets. --- We really ought to use a proper termcap/terminfo library. -do_bold :: Bool -do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] - where mTerm = System.Environment.getEnv "TERM" - `catchIO` \_ -> return "TERM not set" - -start_bold :: String -start_bold = "\ESC[1m" -end_bold :: String -end_bold = "\ESC[0m" - ------------------------------------------------------------------------------ --- :where - -whereCmd :: String -> GHCi () -whereCmd = noArgs $ do - mstrs <- getCallStackAtCurrentBreakpoint - case mstrs of - Nothing -> return () - Just strs -> liftIO $ putStrLn (renderStack strs) - ------------------------------------------------------------------------------ --- :list - -listCmd :: String -> InputT GHCi () -listCmd c = listCmd' c - -listCmd' :: String -> InputT GHCi () -listCmd' "" = do - mb_span <- lift getCurrentBreakSpan - case mb_span of - Nothing -> - printForUser $ text "Not stopped at a breakpoint; nothing to list" - Just (RealSrcSpan pan) -> - listAround pan True - Just pan@(UnhelpfulSpan _) -> - do resumes <- GHC.getResumeContext - case resumes of - [] -> panic "No resumes" - (r:_) -> - do let traceIt = case GHC.resumeHistory r of - [] -> text "rerunning with :trace," - _ -> empty - doWhat = traceIt <+> text ":back then :list" - printForUser (text "Unable to list source for" <+> - ppr pan - $$ text "Try" <+> doWhat) -listCmd' str = list2 (words str) - -list2 :: [String] -> InputT GHCi () -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 - listModuleLine md (read arg) -list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do - md <- wantInterpretedModule arg1 - listModuleLine md (read arg2) -list2 [arg] = do - wantNameFromInterpretedModule noCanDo arg $ \name -> do - let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) - case loc of - RealSrcLoc l -> - do tickArray <- ASSERT( isExternalName name ) - lift $ getTickArray (GHC.nameModule name) - let mb_span = findBreakByCoord (Just (GHC.srcLocFile l)) - (GHC.srcLocLine l, GHC.srcLocCol l) - tickArray - case mb_span of - Nothing -> listAround (realSrcLocSpan l) False - Just (_, pan) -> listAround pan False - UnhelpfulLoc _ -> - noCanDo name $ text "can't find its location: " <> - ppr loc - where - noCanDo n why = printForUser $ - text "cannot list source code for " <> ppr n <> text ": " <> why -list2 _other = - liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]" - -listModuleLine :: Module -> Int -> InputT GHCi () -listModuleLine modl line = do - graph <- GHC.getModuleGraph - let this = filter ((== modl) . GHC.ms_mod) graph - case this of - [] -> panic "listModuleLine" - summ:_ -> do - let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ)) - loc = mkRealSrcLoc (mkFastString (filename)) line 0 - listAround (realSrcLocSpan loc) False - --- | list a section of a source file around a particular SrcSpan. --- If the highlight flag is True, also highlight the span using --- start_bold\/end_bold. - --- GHC files are UTF-8, so we can implement this by: --- 1) read the file in as a BS and syntax highlight it as before --- 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 pan do_highlight = do - contents <- liftIO $ BS.readFile (unpackFS file) - -- Drop carriage returns to avoid duplicates, see #9367. - let ls = BS.split '\n' $ BS.filter (/= '\r') contents - ls' = take (line2 - line1 + 1 + pad_before + pad_after) $ - drop (line1 - 1 - pad_before) $ ls - fst_line = max 1 (line1 - pad_before) - line_nos = [ fst_line .. ] - - highlighted | do_highlight = zipWith highlight line_nos ls' - | otherwise = [\p -> BS.concat[p,l] | l <- ls'] - - bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] - prefixed = zipWith ($) highlighted bs_line_nos - output = BS.intercalate (BS.pack "\n") prefixed - - let utf8Decoded = utf8DecodeByteString output - liftIO $ putStrLn utf8Decoded - where - file = GHC.srcSpanFile pan - line1 = GHC.srcSpanStartLine pan - col1 = GHC.srcSpanStartCol pan - 1 - line2 = GHC.srcSpanEndLine pan - col2 = GHC.srcSpanEndCol pan - 1 - - pad_before | line1 == 1 = 0 - | otherwise = 1 - pad_after = 1 - - highlight | do_bold = highlight_bold - | otherwise = highlight_carets - - highlight_bold no line prefix - | no == line1 && no == line2 - = let (a,r) = BS.splitAt col1 line - (b,c) = BS.splitAt (col2-col1) r - in - BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c] - | no == line1 - = let (a,b) = BS.splitAt col1 line in - BS.concat [prefix, a, BS.pack start_bold, b] - | no == line2 - = let (a,b) = BS.splitAt col2 line in - BS.concat [prefix, a, BS.pack end_bold, b] - | otherwise = BS.concat [prefix, line] - - highlight_carets no line prefix - | no == line1 && no == line2 - = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', - BS.replicate (col2-col1) '^'] - | no == line1 - = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, - prefix, line] - | no == line2 - = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', - BS.pack "^^"] - | otherwise = BS.concat [prefix, line] - where - indent = BS.pack (" " ++ replicate (length (show no)) ' ') - nl = BS.singleton '\n' - - --- -------------------------------------------------------------------------- --- Tick arrays - -getTickArray :: Module -> GHCi TickArray -getTickArray modl = do - st <- getGHCiState - let arrmap = tickarrays st - case lookupModuleEnv arrmap modl of - Just arr -> return arr - Nothing -> do - (_breakArray, ticks) <- getModBreak modl - let arr = mkTickArray (assocs ticks) - setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} - return arr - -discardTickArrays :: GHCi () -discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv}) - -mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray -mkTickArray ticks - = accumArray (flip (:)) [] (1, max_line) - [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ] - where - max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ] - srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] - --- don't reset the counter back to zero? -discardActiveBreakPoints :: GHCi () -discardActiveBreakPoints = do - st <- getGHCiState - mapM_ (turnOffBreak.snd) (breaks st) - setGHCiState $ st { breaks = [] } - -deleteBreak :: Int -> GHCi () -deleteBreak identity = do - st <- getGHCiState - let oldLocations = breaks st - (this,rest) = partition (\loc -> fst loc == identity) oldLocations - if null this - then printForUser (text "Breakpoint" <+> ppr identity <+> - text "does not exist") - else do - mapM_ (turnOffBreak.snd) this - setGHCiState $ st { breaks = rest } - -turnOffBreak :: BreakLocation -> GHCi () -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 m = do - Just mod_info <- GHC.getModuleInfo m - let modBreaks = GHC.modInfoModBreaks mod_info - let arr = GHC.modBreaks_flags modBreaks - let ticks = GHC.modBreaks_locs modBreaks - return (arr, ticks) - -setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi () -setBreakFlag toggle arr i = do - hsc_env <- GHC.getSession - liftIO $ enableBreakpoint hsc_env arr i toggle - --- --------------------------------------------------------------------------- --- User code exception handling - --- This is the exception handler for exceptions generated by the --- user's code and exceptions coming from children sessions; --- it normally just prints out the exception. The --- handler must be recursive, in case showing the exception causes --- more exceptions to be raised. --- --- Bugfix: if the user closed stdout or stderr, the flushing will fail, --- 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 exception = do - flushInterpBuffers - withSignalHandlers $ - ghciHandle handler (showException exception >> return False) - -showException :: SomeException -> GHCi () -showException se = - liftIO $ case fromException se of - -- omit the location for CmdLineError: - Just (CmdLineError s) -> putException s - -- ditto: - Just other_ghc_ex -> putException (show other_ghc_ex) - Nothing -> - case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) - where - putException = hPutStrLn stderr - - ------------------------------------------------------------------------------ --- recursive exception handlers - --- Don't forget to unblock async exceptions in the handler, or if we're --- in an exception loop (eg. let a = error a in a) the ^C exception --- may never be delivered. Thanks to Marcin for pointing out the bug. - -ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a -ghciHandle h m = gmask $ \restore -> do - -- Force dflags to avoid leaking the associated HscEnv - !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) - -tryBool :: GHCi a -> GHCi Bool -tryBool m = do - r <- ghciTry m - case r of - Left _ -> return False - Right _ -> return True - --- ---------------------------------------------------------------------------- --- Utils - -lookupModule :: GHC.GhcMonad m => String -> m Module -lookupModule mName = lookupModuleName (GHC.mkModuleName mName) - -lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module -lookupModuleName mName = GHC.lookupModule mName Nothing - -isHomeModule :: Module -> Bool -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 = liftIO . expandPathIO - -expandPathIO :: String -> IO String -expandPathIO p = - case dropWhile isSpace p of - ('~':d) -> do - tilde <- getHomeDirectory -- will fail if HOME not defined - return (tilde ++ '/':d) - other -> - return other - -wantInterpretedModule :: GHC.GhcMonad m => String -> m Module -wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) - -wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module -wantInterpretedModuleName modname = do - modl <- lookupModuleName modname - let str = moduleNameString modname - dflags <- getDynFlags - when (GHC.moduleUnitId modl /= thisPackage dflags) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) - is_interpreted <- GHC.moduleIsInterpreted modl - when (not is_interpreted) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) - return modl - -wantNameFromInterpretedModule :: GHC.GhcMonad m - => (Name -> SDoc -> m ()) - -> String - -> (Name -> m ()) - -> m () -wantNameFromInterpretedModule noCanDo str and_then = - handleSourceError GHC.printException $ do - names <- GHC.parseName str - case names of - [] -> return () - (n:_) -> do - let modl = ASSERT( isExternalName n ) GHC.nameModule n - if not (GHC.isExternalName n) - then noCanDo n $ ppr n <> - text " is not defined in an interpreted module" - else do - is_interpreted <- GHC.moduleIsInterpreted modl - if not is_interpreted - then noCanDo n $ text "module " <> ppr modl <> - text " is not interpreted" - else and_then n - - ------------------------------------------------------------------------------------------------- --- DAP Utility ------------------------------------------------------------------------------------------------- - --- | --- -saveTraceCmdExecResult :: Maybe ExecResult -> GHCi (Maybe ExecResult) -saveTraceCmdExecResult res = do - mvarCtx <- dapContextGHCiState <$> getGHCiState - - ctx <- liftIO $ takeMVar mvarCtx - let cur = DAP.traceCmdExecResultDAPContext ctx - - liftIO $ putMVar mvarCtx ctx{DAP.traceCmdExecResultDAPContext = res : cur} - - return res - - --- | --- -saveDoContinueExecResult :: ExecResult -> GHCi ExecResult -saveDoContinueExecResult res = do - mvarCtx <- dapContextGHCiState <$> getGHCiState - - ctx <- liftIO $ takeMVar mvarCtx - let cur = DAP.doContinueExecResultDAPContext ctx - - liftIO $ putMVar mvarCtx ctx{DAP.doContinueExecResultDAPContext = res : cur} - - return res - +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ ghciCommands,+ ghciWelcomeMsg,++ -- haskell-dap add.+ defaultGhciSettings,+ getLoadedModules,+ breakCmd,+ deleteCmd,+ traceCmd,+ stepCmd,+ stepLocalCmd,+ runStmt,+ toBreakIdAndLocation+ ) where++#include "HsVersions.h"++-- GHCi+import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls )+import GHCi.UI.Monad hiding ( args, runStmt, runDecls )+import GHCi.UI.Tags+import GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+ getModuleGraph, handleSourceError )+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+ setInteractivePrintName, hsc_dflags, msObjFilePath )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+ listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Config+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,+ partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#ifndef mingw32_HOST_OS+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++------------------------------------------------------------------------------+-- DAP+------------------------------------------------------------------------------+import qualified Haskell.DAP.GHCi.Type as DAP+import InteractiveEval (ExecResult)+import Control.Concurrent+++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction,+ dapContextGhciSettings :: DAP.MVarDAPContext+ }++defaultGhciSettings :: DAP.MVarDAPContext -> GhciSettings+defaultGhciSettings dapCtx =+ GhciSettings {+ availableCommands = ghciCommands,+ shortHelpText = defShortHelpText,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText,+ dapContextGhciSettings = dapCtx+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion +++ ": http://www.haskell.org/ghc/ :? for help"++ghciCommands :: [Command]+ghciCommands = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeIdentifier),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("edit", keepGoing' editFile, completeFilename),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> liftIO $ hPutStrLn stderr err+ Right args -> a args+ return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>" +++ "set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if mingw32_HOST_OS+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ dflags <- getDynFlags+ let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)+ . (`xopt_unset` LangExt.MonomorphismRestriction)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ progDynFlags { log_action = ghciLogAction lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = default_prompt,+ prompt_cont = default_prompt_cont,+ stop = default_stop,+ editor = default_editor,+ options = [],+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering,+ dapContextGHCiState = dapContextGhciSettings config+ }++ return ()++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] -> LogAction+ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do+ defaultLogAction dflags flag severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "ghc")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ current_dir = return (Just ".ghci")++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".ghci"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ dot_cfgs <- if ignore_dot_ghci then return [] else do+ dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+ liftIO $ filterM checkFileAndDirPerms dot_files+ mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)+ mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs+ -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ -- is_tty <- liftIO (hIsTerminalDevice stdin)+ is_tty <- liftIO (return True)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".ghci_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#ifdef mingw32_HOST_OS+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#ifdef mingw32_HOST_OS+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GHCi (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS = \_ _ -> do+ (context, modules_names, line) <- getInfoForPrompt++ let+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = context <> modules_bit+ modules_bit = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++ processString promptS++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ (name:_) <- GHC.parseName ipFun+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+ -- We want to return () here, but have to return (Maybe Bool)+ -- because gmask is not polymorphic enough: we want to use+ -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return Nothing+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the commmand was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail+ (doCommand c)+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `GHC.gfinally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi (Maybe Bool)++ -- command+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+ result <- specialCommand cmd+ case result of+ True -> return Nothing+ _ -> return $ Just True++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return $ Just True+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $ Just (runSuccess result)+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ result <- timeIt runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ Just (runSuccess result)++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout :: String -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | 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 stmt step = do+ dflags <- GHC.getInteractiveDynFlags+ if | GHC.isStmt dflags stmt -> run_stmt+ | GHC.isImport dflags stmt -> run_import+ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport dflags stmt -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> run_decl++ where+ run_import = do+ addImportToContext stmt+ return (Just (GHC.ExecComplete (Right []) 0))++ run_decl =+ do _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls stmt+ case m_result of+ Nothing -> return Nothing+ Just result ->+ Just <$> afterRunStmt (const True)+ (GHC.ExecComplete (Right result) 0)++ run_stmt =+ do -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runStmt stmt step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: [Name] -> GHCi ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: Name -> GHCi ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+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+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> GHCi (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHCi (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: String -> GHCi ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts)+ = pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null graph)) $+ 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 []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ dflags <- getDynFlags+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behaviour with and without -fexternal-interpreter)+ when (gopt Opt_ExternalInterpreter dflags) $+ lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+ do file <- if null str then lift chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- 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 =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <- filterM hasFailed graph+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ liftIO $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTy_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ 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 fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: String -> GHCi ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHCi (LHsExpr RdrName)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTy_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+ return $ noLoc $ ExprWithTySig body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False+++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | 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 load =+ gbracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (const Nothing) (loadModule' fs)++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ GHC.setTargets targets+ doLoadAndCollectInfo False LoadAllTargets++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+ lift revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ mapM_ GHC.addTarget targets+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- 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 retain_context howmuch = do+ doCollectInfo <- lift (isOptionSet CollectInfo)++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag++doLoad :: Bool -> LoadHowMuch -> InputT GHCi 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++ lift 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.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad :: SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> InputT GHCi ()+afterLoad ok retain_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in+ load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | 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 ()++setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- 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 = filterM is_pkg_import+ where+ is_pkg_import :: InteractiveImport -> GHCi Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual++ msg <- if gopt Opt_ShowLoadedModules dflags+ then do+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ return $ status <> text ", modules loaded:" <+> mod_commas+ else do+ return $ status <> text ","+ <+> speakNOf (length mods) (text "module") <+> "loaded."++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ where+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath mod)+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ (mkRealSrcLoc fs el ec)++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS s+showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ ec = srcSpanEndCol spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: String -> InputT GHCi Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: String -> InputT GHCi ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lift $ lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == moduleUnitId md = True+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- lift $ wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lift $ 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+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- 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 bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: String -> GHCi ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+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+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: ModuleName -> GHCi ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GHCi a -> GHCi a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: InteractiveImport -> GHCi ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GHCi ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]+getImplicitPreludeImports iidecls = do+ dflags <- GHC.getInteractiveDynFlags+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Prelude"++sameImpModule :: ImportDecl RdrName -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (ideclQualified d1) || ideclQualified d2)+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: String -> GHCi ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: Bool -> GHCi ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags)++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ if all ((/= nm) . fst) old_breaks+ then printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ else do+ let new_breaks = map fn old_breaks+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })+ | otherwise = (i,loc)+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: Bool -> [String] -> GHCi ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ GHC.setInteractiveDynFlags idflags1+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags+ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ liftIO $ linkPackages hsc_env new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: String -> GHCi ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: String -> GHCi ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags++ let lookupCmd :: String -> Maybe (GHCi ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> GHCi () -> (Bool, String, GHCi ())+ action name m = (True, name, m)++ hidden :: String -> GHCi () -> (Bool, String, GHCi ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ getDynFlags >>= liftIO . showLinkerState+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showPackages+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: String -> GHCi ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GHCi ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) graph++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ docs <- mapM makeDoc (reverse bindings)+ -- reverse so the new ones come last+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++showBkptTable :: GHCi ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHCi ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHCi ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name g+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- 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++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ Just md <- getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: String -> GHCi ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >>= saveTraceCmdExecResult >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+ runResult <- resume pre step+ saveDoContinueExecResult runResult+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: String -> GHCi ()+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 argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: String -> GHCi ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++historyCmd :: String -> GHCi ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+ case maybe_info of+ Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+ Just minf ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakForBind name (GHC.modInfoModBreaks minf)+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi ()+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 md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (not a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+ n == occNameString (nameOccName name),+ RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: String -> GHCi ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+ mb_span <- lift getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd' str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+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+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = filter ((== modl) . GHC.ms_mod) graph+ case this of+ [] -> panic "listModuleLine"+ summ:_ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 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 pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: Module -> GHCi TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GHCi ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GHCi ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnOffBreak.snd) (breaks st)+ setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations+ if null this+ then printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ else do+ mapM_ (turnOffBreak.snd) this+ setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+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 m = do+ Just mod_info <- GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- 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 exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !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)++tryBool :: GHCi a -> GHCi Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+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 = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.moduleUnitId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n+++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+saveTraceCmdExecResult :: Maybe ExecResult -> GHCi (Maybe ExecResult)+saveTraceCmdExecResult res = do+ mvarCtx <- dapContextGHCiState <$> getGHCiState ++ ctx <- liftIO $ takeMVar mvarCtx+ let cur = DAP.traceCmdExecResultDAPContext ctx++ liftIO $ putMVar mvarCtx ctx{DAP.traceCmdExecResultDAPContext = res : cur}++ return res+++-- |+--+saveDoContinueExecResult :: ExecResult -> GHCi ExecResult+saveDoContinueExecResult res = do+ mvarCtx <- dapContextGHCiState <$> getGHCiState ++ ctx <- liftIO $ takeMVar mvarCtx+ let cur = DAP.doContinueExecResultDAPContext ctx++ liftIO $ putMVar mvarCtx ctx{DAP.doContinueExecResultDAPContext = res : cur}++ return res+
app/Haskell/DAP/GHCi/Command.hs view
@@ -1,1488 +1,1488 @@-{-# LANGUAGE LambdaCase #-} - -module Haskell.DAP.GHCi.Command where - -import qualified GHC -import GhcMonad -import HscTypes -import RdrName -import Outputable -import PprTyThing -import Debugger -import Exception -import FastString -import DataCon -import DynFlags -import RtClosureInspect -import InteractiveEvalTypes -import qualified Module as GHC -import qualified GHCi.UI as GHCi -import qualified GHCi.UI.Monad as GHCi hiding (runStmt) - -import Control.DeepSeq (deepseq) -import Control.Monad.Trans.Class -import Control.Concurrent -import Control.Monad - -import qualified Data.Map as M -import qualified Data.List as L - -import System.Console.Haskeline - -import qualified GHCi.DAP.IFData as D -import Haskell.DAP.GHCi.Type -import Haskell.DAP.GHCi.Constant -import Haskell.DAP.GHCi.Utility - - --- | --- -dapCommands :: MVar DAPContext -> [GHCi.Command] -dapCommands ctx = map mkCmd [ - ("dap-echo", dapEcho, noCompletion) - , ("dap-scopes", dapCmdRunner dapScopesCommand ctx, noCompletion) - , ("dap-set-breakpoints", dapCmdRunner dapSetBreakpointsCommand ctx, noCompletion) - , ("dap-set-function-breakpoints" - , dapCmdRunner dapSetFunctionBreakpointsCommand ctx, noCompletion) - , ("dap-set-function-breakpoint" - , dapCmdRunner dapSetFuncBreakpointCommand ctx, noCompletion) - , ("dap-delete-breakpoint" - , dapCmdRunner dapDeleteBreakpointCommand ctx, noCompletion) - , ("dap-continue", dapCmdRunner dapContinueCommand ctx, noCompletion) - , ("dap-next", dapCmdRunner dapNextCommand ctx, noCompletion) - , ("dap-step-in", dapCmdRunner dapStepInCommand ctx, noCompletion) - , ("dap-stacktrace", dapCmdRunner dapStackTraceCommand ctx, noCompletion) - , ("dap-variables", dapCmdRunner dapVariablesCommand ctx, noCompletion) - , ("dap-evaluate", dapCmdRunner dapEvaluateCommand ctx, noCompletion) - ] - where - mkCmd (n,a,c) = GHCi.Command { GHCi.cmdName = n - , GHCi.cmdAction = a - , GHCi.cmdHidden = False - , GHCi.cmdCompletionFunc = c - } - - --- | --- -dapCmdRunner :: (MVar DAPContext -> String -> GHCi.GHCi ()) - -> MVar DAPContext -> String -> InputT GHCi.GHCi Bool -dapCmdRunner cmd ctxMVar str = do - - lift $ cmd ctxMVar str - - liftIO $ putStrLn _DAP_CMD_END - - return False - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-echo ------------------------------------------------------------------------------------------------- - --- | --- -dapEcho :: String -> InputT GHCi.GHCi Bool -dapEcho str = do - liftIO $ putStrLn $ "[DAP][INFO] dap-echo \"" ++ str ++ "\"" - return False - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-scopes ------------------------------------------------------------------------------------------------- - --- | --- -dapScopesCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapScopesCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = do - let idx = D.frameIdScopesArguments args - getScopesBody idx - - -- | - -- - getScopesBody :: Int -> GHCi.GHCi (Either String D.ScopesBody) - getScopesBody curIdx = do - -- liftIO $ putStrLn $ "[DAP][getScopesBody] frame id." ++ frameIdStr - oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar - let moveIdx = curIdx - oldIdx - - tyThings <- withMoveIdx moveIdx - gobalTT <- getGlobalBindings - - -- liftIO $ putStrLn $ "[DAP][getScopesBody] tyThings count." ++ show (length tyThings) - ctx <- liftIO $ takeMVar ctxMVar - liftIO $ putMVar ctxMVar ctx { - variableReferenceMapDAPContext = M.empty - , bindingDAPContext = tyThings - , bindingGlobalDAPContext = gobalTT - , frameIdDAPContext = curIdx - } - - return $ Right D.ScopesBody { - D.scopesScopesBody = [ - D.defaultScope{ - D.nameScope = _GHCi_SCOPE - , D.variablesReferenceScope = 1 - , D.namedVariablesScope = Nothing - , D.indexedVariablesScope = Nothing - , D.expensiveScope = False - } - , - D.defaultScope{ - D.nameScope = _GHCi_GLOBAL_SCOPE - , D.variablesReferenceScope = 2 - , D.namedVariablesScope = Nothing - , D.indexedVariablesScope = Nothing - , D.expensiveScope = False - } - ] - } - - -- | - -- - withMoveIdx moveIdx - | 0 == moveIdx = GHC.getBindings - | 0 < moveIdx = back moveIdx - | otherwise = forward moveIdx - - -- | - -- - getGlobalBindings :: GhcMonad m => m [TyThing] - getGlobalBindings = withSession $ \hsc_env -> do - let ic = hsc_IC hsc_env - gb = ic_rn_gbl_env ic - es = globalRdrEnvElts gb - ns = map gre_name es - foldM withName [] $ reverse ns - - -- | - -- - back num = do - (names, _, _, _) <- GHC.back num - st <- GHCi.getGHCiState - enqueueCommands [GHCi.stop st] - - foldM withName [] $ reverse names - - - -- | - -- - forward num = do - (names, _, _, _) <- GHC.forward num - st <- GHCi.getGHCiState - enqueueCommands [GHCi.stop st] - - foldM withName [] $ reverse names - - -- | - -- - enqueueCommands :: [String] -> GHCi.GHCi () - enqueueCommands cmds = do - -- make sure we force any exceptions in the commands while we're - -- still inside the exception handler, otherwise bad things will - -- happen (see #10501) - cmds `deepseq` return () - GHCi.modifyGHCiState $ \st -> st{ GHCi.cmdqueue = cmds ++ GHCi.cmdqueue st } - - -- | - -- - withName acc n = GHC.lookupName n >>= \case - Just ty -> return (ty : acc) - Nothing -> do - dflags <- getDynFlags - liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] variable not found. " ++ showSDoc dflags (ppr n) - return acc - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-set-breakpoints ------------------------------------------------------------------------------------------------- - --- | --- -dapSetBreakpointsCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapSetBreakpointsCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - -- | - -- - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = getModule args >>= \case - Left msg -> return $ Left msg - Right mod -> do - deleteBreakpoints mod - - addBreakpoints args mod - - - -- | - -- - getModule args = do - let srcInfo = D.sourceSetBreakpointsArguments args - srcPath = D.pathSource srcInfo - - modSums <- GHCi.getLoadedModules - let modPaths = map takeModPath modSums - - case filter (isPathMatch srcPath) modPaths of - ((m, p):[]) -> do - liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m - return $ Right m - _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths - - - -- | - -- - deleteBreakpoints :: ModuleName -> GHCi.GHCi () - deleteBreakpoints mod = do - bps <- liftIO $ getDelBPs mod - - liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] delete src bps " ++ show bps - - mapM_ delBreakpoint bps - - -- | - -- - getDelBPs :: ModuleName -> IO [Int] - getDelBPs mod = do - ctx <- takeMVar ctxMVar - - let bpNOs = M.keys $ M.filter ((isModuleMatch mod)) $ srcBPsDAPContext ctx - newSrcBPs = M.filter (not . (isModuleMatch mod)) $ srcBPsDAPContext ctx - - putMVar ctxMVar $ ctx {srcBPsDAPContext = newSrcBPs} - - return bpNOs - - -- | - -- - isModuleMatch :: ModuleName -> SourceBreakpointInfo -> Bool - isModuleMatch mod bpInfo = mod == modNameSourceBreakpointInfo bpInfo - - - -- | - -- - takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms) - - -- | - -- - isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p) - - -- | - -- - addBreakpoints :: D.SetBreakpointsArguments -> ModuleName -> GHCi.GHCi (Either String D.SetBreakpointsResponseBody) - addBreakpoints args mod = do - let srcBPs = D.breakpointsSetBreakpointsArguments args - - addBps <- mapM (addBP mod) srcBPs - - liftIO $ updateBpCtx addBps - - return $ Right $ D.SetBreakpointsResponseBody $ map takeBp addBps - - -- | - -- - addBP :: String -> D.SourceBreakpoint -> GHCi.GHCi (ModuleName, D.SourceBreakpoint, D.Breakpoint) - addBP mod srcBP = do - let lineNo = show $ D.lineSourceBreakpoint srcBP - colNo = getColNo $ D.columnSourceBreakpoint srcBP - argStr = mod ++ " " ++ lineNo ++ " " ++ colNo - - bp <- addBreakpoint argStr - - return (mod, srcBP, bp) - - -- | - -- - getColNo :: Maybe Int -> String - getColNo Nothing = "" - getColNo (Just 1) = "" - getColNo (Just a) = show a - - -- | - -- - updateBpCtx :: [(ModuleName, D.SourceBreakpoint, D.Breakpoint)] -> IO () - updateBpCtx bps = do - ctx <- takeMVar ctxMVar - let cur = srcBPsDAPContext ctx - new = M.fromList $ foldr convSrcBps [] bps - putMVar ctxMVar $ ctx{srcBPsDAPContext = (M.union cur new)} - - -- | - -- - convSrcBps :: (ModuleName, D.SourceBreakpoint, D.Breakpoint) - -> [(Int, SourceBreakpointInfo)] - -> [(Int, SourceBreakpointInfo)] - convSrcBps (mod, srcBp, bp) acc = case D.idBreakpoint bp of - Nothing -> acc - Just no -> (no, SourceBreakpointInfo mod srcBp 0) : acc - - -- | - -- - takeBp :: (ModuleName, D.SourceBreakpoint, D.Breakpoint) -> D.Breakpoint - takeBp (_, _, bp) = bp - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-set-function-breakpoints ------------------------------------------------------------------------------------------------- - --- | --- -dapSetFunctionBreakpointsCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapSetFunctionBreakpointsCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = deleteBreakpoints - >> addBreakpoints args - - -- | - -- - deleteBreakpoints :: GHCi.GHCi () - deleteBreakpoints = do - bps <- liftIO $ getDelBPs - - liftIO $ putStrLn $ "[DAP][INFO][dapSetFunctionBreakpointsCommand] delete func bps " ++ show bps - - mapM_ delBreakpoint bps - - -- | - -- - getDelBPs :: IO [Int] - getDelBPs = do - ctx <- takeMVar ctxMVar - - let bpNOs = M.keys $ funcBPsDAPContext ctx - - putMVar ctxMVar $ ctx {funcBPsDAPContext = M.fromList []} - - return bpNOs - - -- | - -- - addBreakpoints :: D.SetFunctionBreakpointsArguments -> GHCi.GHCi (Either String D.SetFunctionBreakpointsResponseBody) - addBreakpoints args = do - let funcBPs = D.breakpointsSetFunctionBreakpointsArguments args - - addBps <- mapM addBP funcBPs - - liftIO $ updateBpCtx addBps - - return $ Right $ D.SetFunctionBreakpointsResponseBody $ map snd addBps - - -- | - -- - addBP :: D.FunctionBreakpoint -> GHCi.GHCi (D.FunctionBreakpoint, D.Breakpoint) - addBP funcBP = do - let argStr = D.nameFunctionBreakpoint funcBP - - bp <- addBreakpoint argStr - - return (funcBP, bp) - - -- | - -- - updateBpCtx :: [(D.FunctionBreakpoint, D.Breakpoint)] -> IO () - updateBpCtx bps = do - ctx <- takeMVar ctxMVar - let new = foldr getBpNo [] bps - - putMVar ctxMVar $ ctx{funcBPsDAPContext = M.fromList new} - - -- | - -- - getBpNo :: (D.FunctionBreakpoint, D.Breakpoint) - -> [(Int, (D.FunctionBreakpoint, Int))] - -> [(Int, (D.FunctionBreakpoint, Int))] - getBpNo (funcBP, bp) acc = case D.idBreakpoint bp of - Nothing -> acc - Just no -> (no, (funcBP, 0)) : acc - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-set-function-breakpoint-adhoc ------------------------------------------------------------------------------------------------- - --- | --- -dapSetFuncBreakpointCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapSetFuncBreakpointCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right (startup, funcBP)) = getModuleByFile startup >>= \case - Left err -> return $ Left err - Right modName -> do - let funcName = D.nameFunctionBreakpoint funcBP - argStr = modName ++ "." ++ funcName - - bp <- addBreakpoint argStr - liftIO $ updateBpCtx (funcBP, bp) - - return $ Right bp - {- - -- | - -- - addBP :: (String, D.FunctionBreakpoint) -> GHCi.GHCi (D.FunctionBreakpoint, D.Breakpoint) - addBP (startup, funcBP) = getModuleByFile startup >>= withMod funcBP - - withMod funcBP (Right modName) = do - let funcName = D.nameFunctionBreakpoint funcBP - argStr = modName ++ "." ++ funcName - - bp <- addBreakpoint argStr - - return (funcBP, bp) --} - -- | - -- - updateBpCtx :: (D.FunctionBreakpoint, D.Breakpoint) -> IO () - updateBpCtx (funcBP, bp) = case D.idBreakpoint bp of - Nothing -> return () - Just no -> do - ctx <- takeMVar ctxMVar - let funcBpMap = funcBPsDAPContext ctx - - putMVar ctxMVar $ ctx{funcBPsDAPContext = M.insert no (funcBP, 0) funcBpMap} - - --- | --- -getModuleByFile :: String -> GHCi.GHCi (Either String String) -getModuleByFile srcPath = do - - modSums <- GHCi.getLoadedModules - let modPaths = map takeModPath modSums - - case filter (isPathMatch srcPath) modPaths of - ((m, _):[]) -> do - -- liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m - return $ Right m - _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths - - where - takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms) - isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p) - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-delete-breakpoint-adhoc ------------------------------------------------------------------------------------------------- - --- | --- -dapDeleteBreakpointCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapDeleteBreakpointCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right bp) = withBpId $ D.idBreakpoint bp - - withBpId Nothing = return $ Left $ "[DAP][ERROR] breakpoint number not found. " ++ show argsStr - withBpId (Just bid) = do - delBreakpoint bid - liftIO $ updateBpCtx bid - return $ Right () - - -- | - -- - updateBpCtx :: Int -> IO () - updateBpCtx bid = do - ctx <- takeMVar ctxMVar - let funcBpMap = funcBPsDAPContext ctx - - putMVar ctxMVar $ ctx{funcBPsDAPContext = M.delete bid funcBpMap} - ------------------------------------------------------------------------------------------------- - --- | --- -delBreakpoint :: Int -> GHCi.GHCi Bool -delBreakpoint bpNoStr = do - curSt <- GHCi.getGHCiState - let curCount = GHCi.break_ctr curSt - - -- liftIO $ putStrLn $ "[DAP][INFO] before func breaks : " ++ show curCount - GHCi.deleteCmd (show bpNoStr) - - newSt <- GHCi.getGHCiState - let newCount = GHCi.break_ctr newSt - -- liftIO $ putStrLn $ "[DAP][INFO] after func breaks : " ++ show newCount - - -- TODO; GHCi.break_ctr is not changed. - return (newCount == curCount - 1) - - --- | --- -addBreakpoint :: String -> GHCi.GHCi D.Breakpoint -addBreakpoint argStr = do - curSt <- GHCi.getGHCiState - let curCount = GHCi.break_ctr curSt - - GHCi.breakCmd argStr - - newSt <- GHCi.getGHCiState - let newCount = GHCi.break_ctr newSt - isAdded = (newCount == curCount + 1) - locMay = if isAdded then Just (head (GHCi.breaks newSt)) else Nothing - - withBreakLoc locMay - - where - withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (GHCi.breakLoc bpLoc) - withBreakLoc Nothing = return D.defaultBreakpoint { - D.verifiedBreakpoint = False - , D.messageBreakpoint = "[DAP][ERROR]set breakpoint seems to be failed." - } - - withSrcSpan no bpLoc (GHC.RealSrcSpan dat) = return - D.defaultBreakpoint { - D.idBreakpoint = Just no - , D.verifiedBreakpoint = True - , D.sourceBreakpoint = D.defaultSource { - D.nameSource = (Just . GHC.moduleNameString . GHC.moduleName . GHCi.breakModule) bpLoc - , D.pathSource = (unpackFS . GHC.srcSpanFile) dat - , D.sourceReferenceSource = Nothing - , D.origineSource = Nothing - } - , D.lineBreakpoint = GHC.srcSpanStartLine dat - , D.columnBreakpoint = GHC.srcSpanStartCol dat - , D.endLineBreakpoint = GHC.srcSpanEndLine dat - , D.endColumnBreakpoint = GHC.srcSpanEndCol dat - } - - withSrcSpan _ _ (GHC.UnhelpfulSpan _) = return D.defaultBreakpoint { - D.verifiedBreakpoint = False - , D.messageBreakpoint = "[DAP][ERROR] UnhelpfulSpan breakpoint." - } - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-continue ------------------------------------------------------------------------------------------------- - --- | --- -dapContinueCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapContinueCommand mvarCtx argsStr = withArgs (readDAP argsStr) - >>= withStopResult - - where - - -- | - -- - withArgs :: Either String D.ContinueArguments -> GHCi.GHCi (Either String D.StoppedEventBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = case D.exprContinueArguments args of - Just expr -> runWithStmtTrace expr - Nothing -> runNoStmtTrace - - - -- | - -- - runWithStmtTrace expr = do - clearTmpDAPContext - - GHCi.traceCmd expr - - ctx <- liftIO $ readMVar mvarCtx - withStmtTraceResults $ traceCmdExecResultDAPContext ctx - - - -- | - -- - withStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace arg result." - withStmtTraceResults (res:[]) = withStmtTraceResult res - withStmtTraceResults (res:_) = do - liftIO $ putStrLn $ "[DAP][WARN] two or more trace arg results. use first result. " - withStmtTraceResult res - - - -- | - -- - withStmtTraceResult (Just res) = withExecResult mvarCtx "breakpoint" res - withStmtTraceResult Nothing = do - -- runStmt expr error occurred. - msg <- getRunStmtSourceError - return $ Left $ msg - - - -- | - -- - runNoStmtTrace = do - clearTmpDAPContext - - GHCi.traceCmd "" - - ctx <- liftIO $ readMVar mvarCtx - withNoStmtTraceResults $ doContinueExecResultDAPContext ctx - - - -- | - -- - withNoStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace no arg result." - withNoStmtTraceResults (res:[]) = withExecResult mvarCtx "breakpoint" res - withNoStmtTraceResults (res:_) = do - liftIO $ putStrLn $ "[DAP][WARN] two or more trace no arg results. use first result. " - withExecResult mvarCtx "breakpoint" res - - - -- | - -- - withStopResult :: Either String D.StoppedEventBody -> GHCi.GHCi () - withStopResult res@(Right D.StoppedEventBody{D.reasonStoppedEventBody = "breakpoint"}) = breakthrough res - withStopResult res = printDAP res - - - -- | - -- - breakthrough :: Either String D.StoppedEventBody -> GHCi.GHCi () - breakthrough res = isBreakthrough >>= \case - False -> printDAP res - True -> runNoStmtTrace >>= withStopResult - - - -- | - -- - isBreakthrough :: GHCi.GHCi Bool - isBreakthrough = GHC.getResumeContext >>= withResumes - - -- | - -- @return - -- True -> thruough - -- False -> break - -- - withResumes :: [GHC.Resume] -> GHCi.GHCi Bool - withResumes [] = do - liftIO $ putStrLn "[DAP][WARN] invalid resume state." - return False - - withResumes (r:_) = pure (GHC.resumeBreakInfo r) - >>= GHCi.toBreakIdAndLocation - >>= withBreakInfo - - -- | - -- @return - -- True -> thruough - -- False -> break - -- - withBreakInfo :: Maybe (Int, GHCi.BreakLocation) -> GHCi.GHCi Bool - withBreakInfo Nothing = do - liftIO $ putStrLn "[DAP][WARN] invalid resume break info state." - return False - - withBreakInfo (Just (no, _)) = findSrcBP no >>= \case - Just srcBP -> withSrcBP no srcBP - Nothing -> findFuncBP no >>= \case - Just fncBP -> withFuncBP no fncBP - Nothing -> do - liftIO $ putStrLn $ "[DAP][WARN] invalid break no. " ++ show no - return False - - -- | - -- - findSrcBP no = do - srcBPs <- liftIO $ srcBPsDAPContext <$> readMVar mvarCtx - return $ M.lookup no srcBPs - - -- | - -- - findFuncBP no = do - funcBPs <- liftIO $ funcBPsDAPContext <$> readMVar mvarCtx - return $ M.lookup no funcBPs - - -- | - -- @return - -- True -> thruough - -- False -> break - -- - withSrcBP :: Int -> SourceBreakpointInfo -> GHCi.GHCi Bool - withSrcBP no bpInfo = - let bpCond = D.conditionSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo) - bpLog = D.logMessageSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo) - in - srcBreakthroughCounterHandler no bpInfo >>= \case - Just res -> return res - Nothing -> breakthroughCondtionHandler no bpCond >>= \case - Just res -> return res - Nothing -> logPointHandler no bpLog >>= \case - Just res -> return res - Nothing -> return False - - - -- | - -- @return - -- True -> thruough - -- False -> break - -- - withFuncBP no bpInfo = - let bpCond = D.conditionFunctionBreakpoint (fst bpInfo) - in - funcBreakthroughCounterHandler no bpInfo >>= \case - Just res -> return res - Nothing -> breakthroughCondtionHandler no bpCond >>= \case - Just res -> return res - Nothing -> return False - - -- | - -- - srcBreakthroughCounterHandler :: Int -> SourceBreakpointInfo -> GHCi.GHCi (Maybe Bool) - srcBreakthroughCounterHandler _ SourceBreakpointInfo { - srcBPSourceBreakpointInfo = D.SourceBreakpoint { - D.hitConditionSourceBreakpoint = Nothing - } - } = return Nothing - srcBreakthroughCounterHandler no bpInfo@SourceBreakpointInfo { - srcBPSourceBreakpointInfo = D.SourceBreakpoint { - D.hitConditionSourceBreakpoint = Just condStr - } - , hitCntSourceBreakpointInfo = curCnt} = do - let newCnt = curCnt + 1 - stmt = if L.isInfixOf "_CNT" condStr - then "let _CNT = " ++ show newCnt ++ " in " ++ condStr - else "let _CNT = " ++ show newCnt ++ " in _CNT " ++ condStr - - liftIO $ updateSrcBreakCounter no bpInfo{hitCntSourceBreakpointInfo = newCnt} - - runStmtDAP mvarCtx False stmt >>= \case - Left err -> do - liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err - return $ Just False - Right res -> do - liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result. " ++ stmt ++ " -> " ++ show res - return $ Just ("False" == D.resultEvaluateBody res) - - -- | - -- - updateSrcBreakCounter no bpInfo = do - ctx <- takeMVar mvarCtx - let cur = srcBPsDAPContext ctx - new = M.insert no bpInfo cur - putMVar mvarCtx ctx{srcBPsDAPContext = new} - - - -- | - -- - funcBreakthroughCounterHandler :: Int -> (D.FunctionBreakpoint, Int) -> GHCi.GHCi (Maybe Bool) - funcBreakthroughCounterHandler _ (D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Nothing}, _) = return Nothing - funcBreakthroughCounterHandler no info@(D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Just condStr}, curCnt) = do - let newCnt = curCnt + 1 - stmt = if L.isInfixOf "_CNT" condStr - then "let _CNT = " ++ show newCnt ++ " in " ++ condStr - else "let _CNT = " ++ show newCnt ++ " in _CNT " ++ condStr - - liftIO $ updateFuncBreakCounter no (fst info, newCnt) - - runStmtDAP mvarCtx False stmt >>= \case - Left err -> do - liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err - return $ Just False - Right res -> do - when ("Bool" /= D.typeEvaluateBody res) $ - liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res - return $ Just ("False" == D.resultEvaluateBody res) - - - -- | - -- - updateFuncBreakCounter no bpInfo = do - ctx <- takeMVar mvarCtx - let cur = funcBPsDAPContext ctx - new = M.insert no bpInfo cur - putMVar mvarCtx ctx{funcBPsDAPContext = new} - - -- | - -- @return - -- True -> breakthrough - -- False -> break - -- - breakthroughCondtionHandler :: Int -> Maybe String -> GHCi.GHCi (Maybe Bool) - breakthroughCondtionHandler _ Nothing = return Nothing - breakthroughCondtionHandler no (Just stmt) = runStmtDAP mvarCtx False stmt >>= \case - Left err -> do - liftIO $ putStrLn $ "[DAP][ERROR] condition statement fail. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ err - return $ Just False - Right res -> do - when ("Bool" /= D.typeEvaluateBody res) $ - liftIO $ putStrLn $ "[DAP][ERROR] condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res - return $ Just ("False" == D.resultEvaluateBody res) - - -- | - -- @return - -- must be True -> breakthrough - -- - logPointHandler :: Int -> Maybe String -> GHCi.GHCi (Maybe Bool) - logPointHandler _ Nothing = return Nothing - logPointHandler no (Just stmt) = do - runStmtDAP mvarCtx False stmt >>= \case - Left err -> do - let msg = "[DAP][ERROR] logpoint evaluate statement error at BPNO:" ++ show no ++ " error:" ++ err - body = D.defaultOutputEventBody { D.outputOutputEventBody = msg - , D.categoryOutputEventBody = "stderr" } - printOutputEventDAP (Right body) - return $ Just False - - Right res -> do - let msg = D.resultEvaluateBody res ++ "\n" - body = D.defaultOutputEventBody { D.outputOutputEventBody = msg - , D.categoryOutputEventBody = "console"} - - printOutputEventDAP (Right body) - return $ Just True - - --- | --- -withExecResult :: MVar DAPContext -> String-> GHC.ExecResult -> GHCi.GHCi (Either String D.StoppedEventBody) -withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Right _ }) = do - return $ Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "complete" - } - -withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Left (SomeException e)}) = do - return $ Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "complete" - , D.descriptionStoppedEventBody = show e - , D.textStoppedEventBody = show e - } - -withExecResult _ reason (GHC.ExecBreak{GHC.breakInfo = Just (BreakInfo _ _)}) = do - -- liftIO $ putStrLn $ "[DAP][DEBUG] " ++ GHC.moduleNameString (GHC.moduleName m) - -- liftIO $ putStrLn $ "[DAP][DEBUG] " ++ show n - return $ Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = reason - } - -withExecResult mvarCtx _ (GHC.ExecBreak{GHC.breakInfo = Nothing}) = do - let key = "_exception" - --runStmtDAP mvarCtx False key >>= \case - gcatch (GHC.parseName key) parseNameErrorHandler >>= names2EvalBody mvarCtx False key >>= \case - Left msg -> return $ Left $ "[DAP][ERROR] invalid _exception result." ++ msg - Right body -> return $ Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "exception" - , D.descriptionStoppedEventBody = D.resultEvaluateBody body - , D.textStoppedEventBody = D.resultEvaluateBody body - } - -{-do - evalBody <- getEvalBody "_exception" True - return $ Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "exception" - , D.descriptionStoppedEventBody = D.resultEvaluateBody evalBody - , D.textStoppedEventBody = D.resultEvaluateBody evalBody - } - -} - - - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-next ------------------------------------------------------------------------------------------------- - --- | --- -dapNextCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapNextCommand mvarCtx argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs :: Either String D.NextArguments -> GHCi.GHCi (Either String D.StoppedEventBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right _) = do - clearTmpDAPContext - - GHCi.stepLocalCmd "" - - ctx <- liftIO $ readMVar mvarCtx - withResults $ doContinueExecResultDAPContext ctx - - - -- | - -- - withResults [] = return $ Left $ "[DAP][ERROR] invalid stepLocalCmd result." - withResults (res:[]) = withExecResult mvarCtx "step" res - withResults (res:_) = do - liftIO $ putStrLn $ "[DAP][WARN] two or more stepLocalCmd results. use first result. " - withExecResult mvarCtx "step" res - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-step-in ------------------------------------------------------------------------------------------------- - --- | --- -dapStepInCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapStepInCommand mvarCtx argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs :: Either String D.StepInArguments -> GHCi.GHCi (Either String D.StoppedEventBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right _) = do - clearTmpDAPContext - - GHCi.stepCmd "" - - ctx <- liftIO $ readMVar mvarCtx - withResults $ doContinueExecResultDAPContext ctx - - - -- | - -- - withResults [] = return $ Left $ "[DAP][ERROR] invalid stepCmd result." - withResults (res:[]) = withExecResult mvarCtx "step" res - withResults (res:_) = do - liftIO $ putStrLn $ "[DAP][WARN] two or more stepCmd results. use first result. " - withExecResult mvarCtx "step" res - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-stacktrace ------------------------------------------------------------------------------------------------- - --- | --- -dapStackTraceCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapStackTraceCommand ctxMVar argsStr = do - - ctx <- liftIO $ takeMVar ctxMVar - liftIO $ putMVar ctxMVar ctx {frameIdDAPContext = 0} - - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs :: Either String D.StackTraceArguments -> GHCi.GHCi (Either String D.StackTraceBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right _) = GHC.getResumeContext >>= \case - [] -> return $ Left "no stacktrace found." - (r:_) -> withResume r - - withResume r = case isExceptionResume r of - True -> do - dflags <- GHCi.getDynFlags - let maxSize = GHC.ghciHistSize dflags - -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize - - traces <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r - - return $ Right D.defaultStackTraceBody { - D.stackFramesStackTraceBody = traces - , D.totalFramesStackTraceBody = length traces - } - False -> do - dflags <- GHCi.getDynFlags - let start = resume2stackframe r - maxSize = (GHC.ghciHistSize dflags) - 1 - -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize - - hists <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r - - let traces = start : hists - - return $ Right D.defaultStackTraceBody { - D.stackFramesStackTraceBody = traces - , D.totalFramesStackTraceBody = length traces - } - - resume2stackframe r = D.defaultStackFrame { - D.idStackFrame = 0 - , D.nameStackFrame = (getStackFrameTitle r) - , D.sourceStackFrame = D.defaultSource { - D.pathSource = getSrcPath (GHC.resumeSpan r) - } - , D.lineStackFrame = getStartLinet (GHC.resumeSpan r) - , D.columnStackFrame = getStartCol (GHC.resumeSpan r) - , D.endLineStackFrame = getEndLinet (GHC.resumeSpan r) - , D.endColumnStackFrame = getEndCol (GHC.resumeSpan r) - } - - getStackFrameTitle r = maybe "unknown" (GHC.moduleNameString . GHC.moduleName . GHC.breakInfo_module) (GHC.resumeBreakInfo r) - ++ "." - ++ GHC.resumeDecl r - - getSrcPath (GHC.RealSrcSpan dat) = (unpackFS . GHC.srcSpanFile) dat - getSrcPath (GHC.UnhelpfulSpan _) = "UnhelpfulSpan" - - getStartLinet (GHC.RealSrcSpan dat) = GHC.srcSpanStartLine dat - getStartLinet (GHC.UnhelpfulSpan _) = 0 - - getStartCol (GHC.RealSrcSpan dat) = GHC.srcSpanStartCol dat - getStartCol (GHC.UnhelpfulSpan _) = 0 - - getEndLinet (GHC.RealSrcSpan dat) = GHC.srcSpanEndLine dat - getEndLinet (GHC.UnhelpfulSpan _) = 0 - - getEndCol (GHC.RealSrcSpan dat) = GHC.srcSpanEndCol dat - getEndCol (GHC.UnhelpfulSpan _) = 0 - - resumeHist2stackFrame hist = do - span <- GHC.getHistorySpan hist - return D.defaultStackFrame { - D.idStackFrame = 0 - , D.nameStackFrame = L.intercalate ":" (GHC.historyEnclosingDecls hist) - , D.sourceStackFrame = D.defaultSource { - D.pathSource = getSrcPath span - } - , D.lineStackFrame = getStartLinet span - , D.columnStackFrame = getStartCol span - , D.endLineStackFrame = getEndLinet span - , D.endColumnStackFrame = getEndCol span - } - - - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-variables ------------------------------------------------------------------------------------------------- - --- | --- -dapVariablesCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapVariablesCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - withArgs :: Either String D.VariablesArguments -> GHCi.GHCi (Either String D.VariablesBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = do - let idx = D.variablesReferenceVariablesArguments args - - vals <- getBindingVariables ctxMVar idx - - return $ Right $ D.VariablesBody $ L.sortBy compName vals - - compName a b = compare (D.nameVariable a) (D.nameVariable b) - --- | --- -getBindingVariables :: MVar DAPContext -> Int -> GHCi.GHCi [D.Variable] -getBindingVariables ctx idx - | 1 == idx = getBindingVariablesLocal ctx - | 2 == idx = getBindingVariablesGlobal ctx - | otherwise = getBindingVariablesNode ctx idx - - --- | --- -getBindingVariablesLocal :: MVar DAPContext -> GHCi.GHCi [D.Variable] -getBindingVariablesLocal ctxMVar = do - bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar - getBindingVariablesRoot ctxMVar bindings - - --- | --- -getBindingVariablesGlobal :: MVar DAPContext -> GHCi.GHCi [D.Variable] -getBindingVariablesGlobal ctxMVar = do - bindings <- liftIO $ bindingGlobalDAPContext <$> readMVar ctxMVar - getBindingVariablesRoot ctxMVar bindings - - --- | --- -getBindingVariablesRoot :: MVar DAPContext -> [GHC.TyThing] -> GHCi.GHCi [D.Variable] -getBindingVariablesRoot ctxMVar bindings = do - -- bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar - -- liftIO $ putStrLn $ "[DAP][INFO] bindings " ++ show (length bindings) - - foldM go [] bindings - --mapM tyThing2Val bindings - - where - go acc ty = gcatch (doSomething acc ty) (onError acc) - doSomething acc ty = do - v <- tyThing2Val ty - return (v:acc) - onError :: [D.Variable] -> SomeException -> GHCi.GHCi [D.Variable] - onError acc e = do - liftIO $ putStrLn $ "[DAP][DEBUG] ERROR: " ++ (show e) - return acc - - -- | - -- TyThings https://hackage.haskell.org/package/ghc-8.2.1/docs/HscTypes.html#t:TyThing - -- - tyThing2Val :: GHC.TyThing -> GHCi.GHCi D.Variable - tyThing2Val (AnId i) = do - let isForce = True - depth = _BINDING_INSPECT_DEPTH - - GHC.obtainTermFromId depth isForce i >>= withTerm i - - tyThing2Val t@(ATyCon c) = do - dflags <- getDynFlags - return D.defaultVariable { - D.nameVariable = showSDoc dflags (ppr t) - , D.typeVariable = showSDoc dflags (ppr c) - , D.valueVariable = "<define>" - , D.evaluateNameVariable = Nothing - , D.variablesReferenceVariable = 0 - } - - tyThing2Val t@(AConLike c) = do - dflags <- getDynFlags - return D.defaultVariable { - D.nameVariable = showSDoc dflags (ppr t) - , D.typeVariable = showSDoc dflags (ppr c) - , D.valueVariable = "<define>" - , D.evaluateNameVariable = Nothing - , D.variablesReferenceVariable = 0 - } - - tyThing2Val x = do - dflags <- getDynFlags - return D.defaultVariable { - D.nameVariable = showSDoc dflags (ppr x) - , D.typeVariable = "not yet supported tything." - , D.valueVariable = "not yet supported tything." - , D.evaluateNameVariable = Nothing - , D.variablesReferenceVariable = 0 - } - - -- | - -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html - -- - withTerm :: GHC.Id -> Term -> GHCi.GHCi D.Variable - withTerm i t@(Term ty _ _ _) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm t) showTermErrorHandler - let nameStr = showSDoc dflags (ppr i) - typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - nextIdx <- getNextIdx ctxMVar t nameStr - - return D.defaultVariable { - D.nameVariable = nameStr - , D.typeVariable = typeStr - , D.valueVariable = valStr - , D.evaluateNameVariable = Just nameStr - , D.variablesReferenceVariable = nextIdx - } - - withTerm i _ = do - dflags <- getDynFlags - idSDoc <- pprTypeAndContents i - - let (nameStr, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc) - {- - let nameStr = takeWhile (/= ' ') $ showSDoc dflags idSDoc - typeStr = showSDoc dflags idSDoc - valStr = "<define>" - -} - - return D.defaultVariable { - D.nameVariable = nameStr - , D.typeVariable = typeStr - , D.valueVariable = valStr - , D.evaluateNameVariable = Nothing - , D.variablesReferenceVariable = 0 - } - - --- | --- -getNextIdx :: MVar DAPContext -> Term -> String -> GHCi.GHCi Int -getNextIdx ctxMVar t@(Term ty _ _ subTerms) str = getDynFlags >>= withDynFlags - where - withDynFlags dflags - | 0 == length subTerms = return 0 - | 1 == length subTerms && isPrim (head subTerms) = return 0 - | "[Char]" == showSDoc dflags (pprTypeForUser ty) = return 0 - | "String" == showSDoc dflags (pprTypeForUser ty) = return 0 - | otherwise = liftIO $ addTerm2VariableReferenceMap ctxMVar t str - -getNextIdx ctxMVar t str = liftIO $ addTerm2VariableReferenceMap ctxMVar t str - - --- | --- -addTerm2VariableReferenceMap :: MVar DAPContext -> Term -> String -> IO Int -addTerm2VariableReferenceMap ctxMVar t str = do - ctx <- takeMVar ctxMVar - let curMap = variableReferenceMapDAPContext ctx - nextId = (M.size curMap) + 10 - - putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap} - - return nextId - - --- | --- -getDataConstructor :: Term -> GHCi.GHCi String -getDataConstructor (Term _ (Left dc) _ _) = return dc -getDataConstructor (Term _ (Right dc) _ _) = do - dflags <- getDynFlags - let conStr = if isTupleDataCon dc then "Tuple" else showSDoc dflags $ ppr $ dataConName dc - conStr' = if ":" == conStr then "List" else conStr - typeStr = showSDoc dflags (pprTypeForUser (dataConRepType dc)) - return $ conStr' ++ " :: " ++ typeStr -getDataConstructor _ = return "[getDataConstructor] not supported type." - - - --- | --- -getBindingVariablesNode :: MVar DAPContext -> Int -> GHCi.GHCi [D.Variable] -getBindingVariablesNode ctxMVar idx = do - ctx <- liftIO $ readMVar ctxMVar - case M.lookup idx (variableReferenceMapDAPContext ctx) of - Just (t, str) -> withTerm t str - Nothing -> do - liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] id not found. " ++ show idx - return [] - - where - withTerm (Term _ (Right dc) _ subTerms) str = do - let labels = if 0 == length (dataConFieldLabels dc) - then map (\i->"_" ++ show i) [1..(length subTerms)] - else map (unpackFS . flLabel) (dataConFieldLabels dc) - mapM (withSubTerm str) $ zip labels subTerms - - withTerm (Term _ (Left _) _ subTerms) str = do - let labels = map (\i->"_" ++ show i) [1..(length subTerms)] - mapM (withSubTerm str) $ zip labels subTerms - - withTerm _ _ = do - liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] invalid map term type. " ++ show idx - return [] - - withSubTerm evalStr (label, t@(Term ty _ _ _)) = do - -- liftIO $ putStrLn $ "[DEBUG]" ++ " subTerms. [" ++ show (length subTerms) ++ "]" - termSDoc <- gcatch (showTerm t) showTermErrorHandler - dflags <- getDynFlags - - let nameStr = label - typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - nextIdx <- getNextIdx ctxMVar t evalStr - valStr' <- if 0 == nextIdx then return valStr - else getDataConstructor t - return D.defaultVariable { - D.nameVariable = nameStr - , D.typeVariable = typeStr - , D.valueVariable = valStr' - , D.evaluateNameVariable = Just evalStr - , D.variablesReferenceVariable = nextIdx - } - withSubTerm evalStr (label, (Prim ty val)) = do - dflags <- getDynFlags - return D.defaultVariable { - D.nameVariable = label - , D.typeVariable = showSDoc dflags (pprTypeForUser ty) - , D.valueVariable = showSDoc dflags (ppr val) - , D.evaluateNameVariable = Just evalStr - , D.variablesReferenceVariable = 0 - } - withSubTerm evalStr (label, (Suspension _ ty _ _)) = do - dflags <- getDynFlags - return D.defaultVariable { - D.nameVariable = label - , D.typeVariable = showSDoc dflags (pprTypeForUser ty) - , D.valueVariable = "function :: " ++ showSDoc dflags (pprTypeForUser ty) - , D.evaluateNameVariable = Just evalStr - , D.variablesReferenceVariable = 0 - } - withSubTerm evalStr (label, _) = return D.defaultVariable { - D.nameVariable = label - , D.typeVariable = "not supported subTerm." - , D.valueVariable = "not supported subTerm." - , D.evaluateNameVariable = Just evalStr - , D.variablesReferenceVariable = 0 - } - ------------------------------------------------------------------------------------------------- --- DAP Command :dap-evaluate ------------------------------------------------------------------------------------------------- - --- | --- -dapEvaluateCommand :: MVar DAPContext -> String -> GHCi.GHCi () -dapEvaluateCommand ctxMVar argsStr = do - res <- withArgs (readDAP argsStr) - printDAP res - - where - -- | - -- - withArgs :: Either String D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody) - withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = case D.contextEvaluateArguments args of - Nothing -> runRepl args - Just "repl" -> runRepl args - _ -> runOther args - - -- | - -- - runRepl :: D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody) - runRepl args - | null (D.expressionEvaluateArguments args) = return $ Right D.defaultEvaluateBody { - D.resultEvaluateBody = "no input." - , D.typeEvaluateBody = "no input." - , D.variablesReferenceEvaluateBody = 0 - } - | otherwise = do - let stmt = D.expressionEvaluateArguments args - isRefable = True - - runStmtDAP ctxMVar isRefable stmt - - -- | - -- - runOther :: D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody) - runOther args = do - let nameStr = D.expressionEvaluateArguments args - names <- gcatch (GHC.parseName nameStr) parseNameErrorHandler - names2EvalBody ctxMVar True nameStr names - - --- | --- -runStmtDAP :: MVar DAPContext -> Bool -> String -> GHCi.GHCi (Either String D.EvaluateBody) -runStmtDAP ctxMVar isRefable stmt = do - clearTmpDAPContext - - GHCi.runStmt stmt GHC.RunToCompletion >>= \case - Nothing -> Left <$> getRunStmtSourceError - Just (GHC.ExecBreak _ Nothing) -> return $ Left $ "unexpected break occured while evaluating stmt:" ++ stmt - Just (GHC.ExecBreak _ (Just (BreakInfo (GHC.Module _ modName) idx))) -> do - let modStr = GHC.moduleNameString modName - return $ Left $ "unexpected break occured. breakNo:" ++ show idx - ++ " in " ++ modStr ++ " while evaluating stmt:" ++ stmt - Just (GHC.ExecComplete (Left msg) _) -> return $ Left $ "runStmt error. " ++ show msg - Just (GHC.ExecComplete (Right names) _) -> names2EvalBody ctxMVar isRefable stmt names - - --- | --- --- -names2EvalBody :: MVar DAPContext -> Bool -> String -> [GHC.Name] -> GHCi.GHCi (Either String D.EvaluateBody) -names2EvalBody ctxMVar isRefable key names - | 0 == length names = return $ Left $ "Not in scope. " ++ key - | 1 == length names = withName $ head names - | otherwise = return $ Left $ "Ambiguous name. " ++ key - - where - withName n = GHC.lookupName n >>= \case - Nothing -> return $ Left $ "TyThing not found. " ++ key - Just ty -> withTyThing ty - - withTyThing (AnId i) = do - let isForce = True - depth = _EVALUATE_INSPECT_DEPTH - body <- GHC.obtainTermFromId depth isForce i >>= withTerm i - return $ Right body - - withTyThing x = do - liftIO $ putStrLn "[DAP][INFO] withTyThing x Not yet supported." - dflags <- getDynFlags - return $ Right D.defaultEvaluateBody { - D.resultEvaluateBody = showSDoc dflags (ppr x) - , D.typeEvaluateBody = showSDoc dflags (ppr x) - , D.variablesReferenceEvaluateBody = 0 - } - - -- | - -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html - -- - withTerm :: GHC.Id -> Term -> GHCi.GHCi D.EvaluateBody - withTerm _ t@(Term ty _ _ _) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm t) showTermErrorHandler - let typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - nextIdx <- if True == isRefable then getNextIdx ctxMVar t key else return 0 - valStr' <- if 0 == nextIdx then return valStr - else getDataConstructor t - - -- liftIO $ putStrLn "[DAP][INFO] Term Not yet supported." - - return D.defaultEvaluateBody { - D.resultEvaluateBody = delDQ typeStr valStr' - , D.typeEvaluateBody = typeStr - , D.variablesReferenceEvaluateBody = nextIdx - } - - withTerm _ t@(Prim ty _) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm t) showTermErrorHandler - let typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - -- liftIO $ putStrLn "[DAP][INFO] Prim Not yet supported." - - return D.defaultEvaluateBody { - D.resultEvaluateBody = valStr - , D.typeEvaluateBody = typeStr - , D.variablesReferenceEvaluateBody = 0 - } - - withTerm _ t@(Suspension clsr ty _ _) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm t) showTermErrorHandler - let typeStr = "closure(" ++ show clsr ++ ")" ++ " :: " ++ showSDoc dflags (pprTypeForUser ty) ++ " # " ++ showSDoc dflags termSDoc - - liftIO $ putStrLn "[DAP][INFO] Suspension Not yet supported." - return D.defaultEvaluateBody { - D.resultEvaluateBody = typeStr - , D.typeEvaluateBody = typeStr - , D.variablesReferenceEvaluateBody = 0 - } - - withTerm _ (NewtypeWrap ty _ wt) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm wt) showTermErrorHandler - let typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - liftIO $ putStrLn "[DAP][INFO] NewtypeWrap Not yet supported." - return D.defaultEvaluateBody { - D.resultEvaluateBody = valStr - , D.typeEvaluateBody = typeStr - , D.variablesReferenceEvaluateBody = 0 - } - - withTerm _ (RefWrap ty wt) = do - dflags <- getDynFlags - termSDoc <- gcatch (showTerm wt) showTermErrorHandler - let typeStr = showSDoc dflags (pprTypeForUser ty) - valStr = showSDoc dflags termSDoc - - liftIO $ putStrLn "[DAP][INFO] RefWrap Not yet supported." - return D.defaultEvaluateBody { - D.resultEvaluateBody = valStr - , D.typeEvaluateBody = typeStr - , D.variablesReferenceEvaluateBody = 0 - } - - delDQ :: String -> String -> String - delDQ typ val - | (typ == "[Char]" || typ == "String") - && length val > 2 - && head val == '"' && last val == '"' = tail $ init val - | otherwise = val - +{-# LANGUAGE LambdaCase #-}++module Haskell.DAP.GHCi.Command where++import qualified GHC+import GhcMonad+import HscTypes+import RdrName+import Outputable+import PprTyThing+import Debugger+import Exception+import FastString+import DataCon+import DynFlags+import RtClosureInspect+import InteractiveEvalTypes +import qualified Module as GHC+import qualified GHCi.UI as GHCi+import qualified GHCi.UI.Monad as GHCi hiding (runStmt)++import Control.DeepSeq (deepseq)+import Control.Monad.Trans.Class+import Control.Concurrent+import Control.Monad++import qualified Data.Map as M+import qualified Data.List as L++import System.Console.Haskeline++import qualified GHCi.DAP.IFData as D+import Haskell.DAP.GHCi.Type+import Haskell.DAP.GHCi.Constant+import Haskell.DAP.GHCi.Utility+++-- |+--+dapCommands :: MVar DAPContext -> [GHCi.Command]+dapCommands ctx = map mkCmd [+ ("dap-echo", dapEcho, noCompletion)+ , ("dap-scopes", dapCmdRunner dapScopesCommand ctx, noCompletion)+ , ("dap-set-breakpoints", dapCmdRunner dapSetBreakpointsCommand ctx, noCompletion)+ , ("dap-set-function-breakpoints"+ , dapCmdRunner dapSetFunctionBreakpointsCommand ctx, noCompletion)+ , ("dap-set-function-breakpoint"+ , dapCmdRunner dapSetFuncBreakpointCommand ctx, noCompletion)+ , ("dap-delete-breakpoint"+ , dapCmdRunner dapDeleteBreakpointCommand ctx, noCompletion)+ , ("dap-continue", dapCmdRunner dapContinueCommand ctx, noCompletion)+ , ("dap-next", dapCmdRunner dapNextCommand ctx, noCompletion)+ , ("dap-step-in", dapCmdRunner dapStepInCommand ctx, noCompletion)+ , ("dap-stacktrace", dapCmdRunner dapStackTraceCommand ctx, noCompletion)+ , ("dap-variables", dapCmdRunner dapVariablesCommand ctx, noCompletion)+ , ("dap-evaluate", dapCmdRunner dapEvaluateCommand ctx, noCompletion)+ ]+ where+ mkCmd (n,a,c) = GHCi.Command { GHCi.cmdName = n+ , GHCi.cmdAction = a+ , GHCi.cmdHidden = False+ , GHCi.cmdCompletionFunc = c+ }+++-- |+--+dapCmdRunner :: (MVar DAPContext -> String -> GHCi.GHCi ())+ -> MVar DAPContext -> String -> InputT GHCi.GHCi Bool+dapCmdRunner cmd ctxMVar str = do+ + lift $ cmd ctxMVar str++ liftIO $ putStrLn _DAP_CMD_END++ return False+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-echo+------------------------------------------------------------------------------------------------++-- |+--+dapEcho :: String -> InputT GHCi.GHCi Bool+dapEcho str = do+ liftIO $ putStrLn $ "[DAP][INFO] dap-echo \"" ++ str ++ "\""+ return False+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-scopes+------------------------------------------------------------------------------------------------++-- |+--+dapScopesCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapScopesCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res+ + where+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = do+ let idx = D.frameIdScopesArguments args+ getScopesBody idx++ -- |+ --+ getScopesBody :: Int -> GHCi.GHCi (Either String D.ScopesBody)+ getScopesBody curIdx = do+ -- liftIO $ putStrLn $ "[DAP][getScopesBody] frame id." ++ frameIdStr+ oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar+ let moveIdx = curIdx - oldIdx++ tyThings <- withMoveIdx moveIdx+ gobalTT <- getGlobalBindings++ -- liftIO $ putStrLn $ "[DAP][getScopesBody] tyThings count." ++ show (length tyThings)+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {+ variableReferenceMapDAPContext = M.empty+ , bindingDAPContext = tyThings+ , bindingGlobalDAPContext = gobalTT+ , frameIdDAPContext = curIdx+ }+ + return $ Right D.ScopesBody {+ D.scopesScopesBody = [+ D.defaultScope{+ D.nameScope = _GHCi_SCOPE+ , D.variablesReferenceScope = 1+ , D.namedVariablesScope = Nothing+ , D.indexedVariablesScope = Nothing+ , D.expensiveScope = False+ }+ ,+ D.defaultScope{+ D.nameScope = _GHCi_GLOBAL_SCOPE+ , D.variablesReferenceScope = 2+ , D.namedVariablesScope = Nothing+ , D.indexedVariablesScope = Nothing+ , D.expensiveScope = False+ }+ ]+ }++ -- |+ --+ withMoveIdx moveIdx+ | 0 == moveIdx = GHC.getBindings+ | 0 < moveIdx = back moveIdx+ | otherwise = forward moveIdx+ + -- |+ --+ getGlobalBindings :: GhcMonad m => m [TyThing]+ getGlobalBindings = withSession $ \hsc_env -> do+ let ic = hsc_IC hsc_env+ gb = ic_rn_gbl_env ic+ es = globalRdrEnvElts gb+ ns = map gre_name es+ foldM withName [] $ reverse ns++ -- |+ --+ back num = do+ (names, _, _, _) <- GHC.back num+ st <- GHCi.getGHCiState+ enqueueCommands [GHCi.stop st]++ foldM withName [] $ reverse names++ + -- |+ --+ forward num = do+ (names, _, _, _) <- GHC.forward num+ st <- GHCi.getGHCiState+ enqueueCommands [GHCi.stop st]++ foldM withName [] $ reverse names+ + -- |+ --+ enqueueCommands :: [String] -> GHCi.GHCi ()+ enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ GHCi.modifyGHCiState $ \st -> st{ GHCi.cmdqueue = cmds ++ GHCi.cmdqueue st }++ -- |+ --+ withName acc n = GHC.lookupName n >>= \case+ Just ty -> return (ty : acc)+ Nothing -> do+ dflags <- getDynFlags+ liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] variable not found. " ++ showSDoc dflags (ppr n)+ return acc++ +------------------------------------------------------------------------------------------------+-- DAP Command :dap-set-breakpoints+------------------------------------------------------------------------------------------------++-- |+--+dapSetBreakpointsCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapSetBreakpointsCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ -- |+ --+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = getModule args >>= \case+ Left msg -> return $ Left msg+ Right mod -> do + deleteBreakpoints mod+ + addBreakpoints args mod+++ -- |+ --+ getModule args = do+ let srcInfo = D.sourceSetBreakpointsArguments args+ srcPath = D.pathSource srcInfo++ modSums <- GHCi.getLoadedModules+ let modPaths = map takeModPath modSums++ case filter (isPathMatch srcPath) modPaths of+ ((m, p):[]) -> do+ liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m+ return $ Right m+ _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths+++ -- |+ --+ deleteBreakpoints :: ModuleName -> GHCi.GHCi ()+ deleteBreakpoints mod = do+ bps <- liftIO $ getDelBPs mod++ liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] delete src bps " ++ show bps++ mapM_ delBreakpoint bps++ -- |+ --+ getDelBPs :: ModuleName -> IO [Int]+ getDelBPs mod = do+ ctx <- takeMVar ctxMVar++ let bpNOs = M.keys $ M.filter ((isModuleMatch mod)) $ srcBPsDAPContext ctx+ newSrcBPs = M.filter (not . (isModuleMatch mod)) $ srcBPsDAPContext ctx++ putMVar ctxMVar $ ctx {srcBPsDAPContext = newSrcBPs} ++ return bpNOs++ -- |+ --+ isModuleMatch :: ModuleName -> SourceBreakpointInfo -> Bool+ isModuleMatch mod bpInfo = mod == modNameSourceBreakpointInfo bpInfo+++ -- |+ --+ takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms)++ -- |+ --+ isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)++ -- |+ --+ addBreakpoints :: D.SetBreakpointsArguments -> ModuleName -> GHCi.GHCi (Either String D.SetBreakpointsResponseBody)+ addBreakpoints args mod = do+ let srcBPs = D.breakpointsSetBreakpointsArguments args++ addBps <- mapM (addBP mod) srcBPs++ liftIO $ updateBpCtx addBps++ return $ Right $ D.SetBreakpointsResponseBody $ map takeBp addBps+ + -- |+ --+ addBP :: String -> D.SourceBreakpoint -> GHCi.GHCi (ModuleName, D.SourceBreakpoint, D.Breakpoint)+ addBP mod srcBP = do+ let lineNo = show $ D.lineSourceBreakpoint srcBP+ colNo = getColNo $ D.columnSourceBreakpoint srcBP+ argStr = mod ++ " " ++ lineNo ++ " " ++ colNo++ bp <- addBreakpoint argStr++ return (mod, srcBP, bp)++ -- |+ --+ getColNo :: Maybe Int -> String+ getColNo Nothing = ""+ getColNo (Just 1) = ""+ getColNo (Just a) = show a++ -- |+ --+ updateBpCtx :: [(ModuleName, D.SourceBreakpoint, D.Breakpoint)] -> IO ()+ updateBpCtx bps = do+ ctx <- takeMVar ctxMVar+ let cur = srcBPsDAPContext ctx+ new = M.fromList $ foldr convSrcBps [] bps+ putMVar ctxMVar $ ctx{srcBPsDAPContext = (M.union cur new)}++ -- |+ --+ convSrcBps :: (ModuleName, D.SourceBreakpoint, D.Breakpoint)+ -> [(Int, SourceBreakpointInfo)]+ -> [(Int, SourceBreakpointInfo)]+ convSrcBps (mod, srcBp, bp) acc = case D.idBreakpoint bp of+ Nothing -> acc+ Just no -> (no, SourceBreakpointInfo mod srcBp 0) : acc ++ -- |+ --+ takeBp :: (ModuleName, D.SourceBreakpoint, D.Breakpoint) -> D.Breakpoint+ takeBp (_, _, bp) = bp+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-set-function-breakpoints+------------------------------------------------------------------------------------------------++-- |+--+dapSetFunctionBreakpointsCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapSetFunctionBreakpointsCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = deleteBreakpoints+ >> addBreakpoints args+ + -- |+ --+ deleteBreakpoints :: GHCi.GHCi ()+ deleteBreakpoints = do+ bps <- liftIO $ getDelBPs++ liftIO $ putStrLn $ "[DAP][INFO][dapSetFunctionBreakpointsCommand] delete func bps " ++ show bps++ mapM_ delBreakpoint bps+ + -- |+ --+ getDelBPs :: IO [Int]+ getDelBPs = do+ ctx <- takeMVar ctxMVar++ let bpNOs = M.keys $ funcBPsDAPContext ctx++ putMVar ctxMVar $ ctx {funcBPsDAPContext = M.fromList []} ++ return bpNOs++ -- |+ --+ addBreakpoints :: D.SetFunctionBreakpointsArguments -> GHCi.GHCi (Either String D.SetFunctionBreakpointsResponseBody)+ addBreakpoints args = do+ let funcBPs = D.breakpointsSetFunctionBreakpointsArguments args++ addBps <- mapM addBP funcBPs++ liftIO $ updateBpCtx addBps++ return $ Right $ D.SetFunctionBreakpointsResponseBody $ map snd addBps+ + -- |+ --+ addBP :: D.FunctionBreakpoint -> GHCi.GHCi (D.FunctionBreakpoint, D.Breakpoint)+ addBP funcBP = do+ let argStr = D.nameFunctionBreakpoint funcBP++ bp <- addBreakpoint argStr++ return (funcBP, bp)++ -- |+ --+ updateBpCtx :: [(D.FunctionBreakpoint, D.Breakpoint)] -> IO ()+ updateBpCtx bps = do+ ctx <- takeMVar ctxMVar+ let new = foldr getBpNo [] bps++ putMVar ctxMVar $ ctx{funcBPsDAPContext = M.fromList new}++ -- |+ --+ getBpNo :: (D.FunctionBreakpoint, D.Breakpoint)+ -> [(Int, (D.FunctionBreakpoint, Int))]+ -> [(Int, (D.FunctionBreakpoint, Int))]+ getBpNo (funcBP, bp) acc = case D.idBreakpoint bp of+ Nothing -> acc+ Just no -> (no, (funcBP, 0)) : acc +++------------------------------------------------------------------------------------------------+-- DAP Command :dap-set-function-breakpoint-adhoc+------------------------------------------------------------------------------------------------++-- |+--+dapSetFuncBreakpointCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapSetFuncBreakpointCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right (startup, funcBP)) = getModuleByFile startup >>= \case+ Left err -> return $ Left err+ Right modName -> do+ let funcName = D.nameFunctionBreakpoint funcBP+ argStr = modName ++ "." ++ funcName++ bp <- addBreakpoint argStr+ liftIO $ updateBpCtx (funcBP, bp)++ return $ Right bp+ {-+ -- |+ --+ addBP :: (String, D.FunctionBreakpoint) -> GHCi.GHCi (D.FunctionBreakpoint, D.Breakpoint)+ addBP (startup, funcBP) = getModuleByFile startup >>= withMod funcBP++ withMod funcBP (Right modName) = do+ let funcName = D.nameFunctionBreakpoint funcBP+ argStr = modName ++ "." ++ funcName++ bp <- addBreakpoint argStr+ + return (funcBP, bp)+-}+ -- |+ --+ updateBpCtx :: (D.FunctionBreakpoint, D.Breakpoint) -> IO ()+ updateBpCtx (funcBP, bp) = case D.idBreakpoint bp of+ Nothing -> return ()+ Just no -> do+ ctx <- takeMVar ctxMVar+ let funcBpMap = funcBPsDAPContext ctx++ putMVar ctxMVar $ ctx{funcBPsDAPContext = M.insert no (funcBP, 0) funcBpMap}+++-- |+--+getModuleByFile :: String -> GHCi.GHCi (Either String String)+getModuleByFile srcPath = do++ modSums <- GHCi.getLoadedModules+ let modPaths = map takeModPath modSums++ case filter (isPathMatch srcPath) modPaths of+ ((m, _):[]) -> do+ -- liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m+ return $ Right m+ _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths++ where+ takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms)+ isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)++------------------------------------------------------------------------------------------------+-- DAP Command :dap-delete-breakpoint-adhoc+------------------------------------------------------------------------------------------------++-- |+--+dapDeleteBreakpointCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapDeleteBreakpointCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right bp) = withBpId $ D.idBreakpoint bp++ withBpId Nothing = return $ Left $ "[DAP][ERROR] breakpoint number not found. " ++ show argsStr+ withBpId (Just bid) = do+ delBreakpoint bid+ liftIO $ updateBpCtx bid+ return $ Right ()+ + -- |+ --+ updateBpCtx :: Int -> IO ()+ updateBpCtx bid = do+ ctx <- takeMVar ctxMVar+ let funcBpMap = funcBPsDAPContext ctx++ putMVar ctxMVar $ ctx{funcBPsDAPContext = M.delete bid funcBpMap}++------------------------------------------------------------------------------------------------++-- |+--+delBreakpoint :: Int -> GHCi.GHCi Bool+delBreakpoint bpNoStr = do+ curSt <- GHCi.getGHCiState+ let curCount = GHCi.break_ctr curSt++ -- liftIO $ putStrLn $ "[DAP][INFO] before func breaks : " ++ show curCount+ GHCi.deleteCmd (show bpNoStr)+ + newSt <- GHCi.getGHCiState+ let newCount = GHCi.break_ctr newSt+ -- liftIO $ putStrLn $ "[DAP][INFO] after func breaks : " ++ show newCount+ + -- TODO; GHCi.break_ctr is not changed.+ return (newCount == curCount - 1)+++-- |+--+addBreakpoint :: String -> GHCi.GHCi D.Breakpoint+addBreakpoint argStr = do+ curSt <- GHCi.getGHCiState+ let curCount = GHCi.break_ctr curSt++ GHCi.breakCmd argStr+ + newSt <- GHCi.getGHCiState+ let newCount = GHCi.break_ctr newSt+ isAdded = (newCount == curCount + 1)+ locMay = if isAdded then Just (head (GHCi.breaks newSt)) else Nothing+ + withBreakLoc locMay++ where+ withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (GHCi.breakLoc bpLoc)+ withBreakLoc Nothing = return D.defaultBreakpoint {+ D.verifiedBreakpoint = False+ , D.messageBreakpoint = "[DAP][ERROR]set breakpoint seems to be failed."+ }++ withSrcSpan no bpLoc (GHC.RealSrcSpan dat) = return+ D.defaultBreakpoint {+ D.idBreakpoint = Just no+ , D.verifiedBreakpoint = True+ , D.sourceBreakpoint = D.defaultSource {+ D.nameSource = (Just . GHC.moduleNameString . GHC.moduleName . GHCi.breakModule) bpLoc+ , D.pathSource = (unpackFS . GHC.srcSpanFile) dat+ , D.sourceReferenceSource = Nothing+ , D.origineSource = Nothing+ }+ , D.lineBreakpoint = GHC.srcSpanStartLine dat+ , D.columnBreakpoint = GHC.srcSpanStartCol dat+ , D.endLineBreakpoint = GHC.srcSpanEndLine dat+ , D.endColumnBreakpoint = GHC.srcSpanEndCol dat+ }++ withSrcSpan _ _ (GHC.UnhelpfulSpan _) = return D.defaultBreakpoint {+ D.verifiedBreakpoint = False+ , D.messageBreakpoint = "[DAP][ERROR] UnhelpfulSpan breakpoint."+ }+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-continue+------------------------------------------------------------------------------------------------++-- |+--+dapContinueCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapContinueCommand mvarCtx argsStr = withArgs (readDAP argsStr) + >>= withStopResult++ where+ + -- |+ --+ withArgs :: Either String D.ContinueArguments -> GHCi.GHCi (Either String D.StoppedEventBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = case D.exprContinueArguments args of+ Just expr -> runWithStmtTrace expr+ Nothing -> runNoStmtTrace+++ -- |+ --+ runWithStmtTrace expr = do+ clearTmpDAPContext++ GHCi.traceCmd expr++ ctx <- liftIO $ readMVar mvarCtx+ withStmtTraceResults $ traceCmdExecResultDAPContext ctx+++ -- |+ --+ withStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace arg result."+ withStmtTraceResults (res:[]) = withStmtTraceResult res+ withStmtTraceResults (res:_) = do+ liftIO $ putStrLn $ "[DAP][WARN] two or more trace arg results. use first result. "+ withStmtTraceResult res+ ++ -- |+ --+ withStmtTraceResult (Just res) = withExecResult mvarCtx "breakpoint" res+ withStmtTraceResult Nothing = do+ -- runStmt expr error occurred.+ msg <- getRunStmtSourceError+ return $ Left $ msg+++ -- |+ --+ runNoStmtTrace = do+ clearTmpDAPContext++ GHCi.traceCmd ""++ ctx <- liftIO $ readMVar mvarCtx+ withNoStmtTraceResults $ doContinueExecResultDAPContext ctx+++ -- |+ --+ withNoStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace no arg result."+ withNoStmtTraceResults (res:[]) = withExecResult mvarCtx "breakpoint" res+ withNoStmtTraceResults (res:_) = do+ liftIO $ putStrLn $ "[DAP][WARN] two or more trace no arg results. use first result. "+ withExecResult mvarCtx "breakpoint" res+++ -- |+ --+ withStopResult :: Either String D.StoppedEventBody -> GHCi.GHCi ()+ withStopResult res@(Right D.StoppedEventBody{D.reasonStoppedEventBody = "breakpoint"}) = breakthrough res+ withStopResult res = printDAP res+++ -- |+ --+ breakthrough :: Either String D.StoppedEventBody -> GHCi.GHCi ()+ breakthrough res = isBreakthrough >>= \case+ False -> printDAP res+ True -> runNoStmtTrace >>= withStopResult+++ -- |+ --+ isBreakthrough :: GHCi.GHCi Bool+ isBreakthrough = GHC.getResumeContext >>= withResumes++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withResumes :: [GHC.Resume] -> GHCi.GHCi Bool+ withResumes [] = do+ liftIO $ putStrLn "[DAP][WARN] invalid resume state."+ return False++ withResumes (r:_) = pure (GHC.resumeBreakInfo r)+ >>= GHCi.toBreakIdAndLocation+ >>= withBreakInfo++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withBreakInfo :: Maybe (Int, GHCi.BreakLocation) -> GHCi.GHCi Bool+ withBreakInfo Nothing = do+ liftIO $ putStrLn "[DAP][WARN] invalid resume break info state."+ return False++ withBreakInfo (Just (no, _)) = findSrcBP no >>= \case+ Just srcBP -> withSrcBP no srcBP+ Nothing -> findFuncBP no >>= \case+ Just fncBP -> withFuncBP no fncBP+ Nothing -> do+ liftIO $ putStrLn $ "[DAP][WARN] invalid break no. " ++ show no+ return False++ -- |+ --+ findSrcBP no = do+ srcBPs <- liftIO $ srcBPsDAPContext <$> readMVar mvarCtx+ return $ M.lookup no srcBPs++ -- |+ --+ findFuncBP no = do+ funcBPs <- liftIO $ funcBPsDAPContext <$> readMVar mvarCtx+ return $ M.lookup no funcBPs++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withSrcBP :: Int -> SourceBreakpointInfo -> GHCi.GHCi Bool+ withSrcBP no bpInfo = + let bpCond = D.conditionSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo)+ bpLog = D.logMessageSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo)+ in+ srcBreakthroughCounterHandler no bpInfo >>= \case+ Just res -> return res+ Nothing -> breakthroughCondtionHandler no bpCond >>= \case+ Just res -> return res+ Nothing -> logPointHandler no bpLog >>= \case+ Just res -> return res+ Nothing -> return False+++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withFuncBP no bpInfo = + let bpCond = D.conditionFunctionBreakpoint (fst bpInfo)+ in+ funcBreakthroughCounterHandler no bpInfo >>= \case+ Just res -> return res+ Nothing -> breakthroughCondtionHandler no bpCond >>= \case+ Just res -> return res+ Nothing -> return False++ -- |+ --+ srcBreakthroughCounterHandler :: Int -> SourceBreakpointInfo -> GHCi.GHCi (Maybe Bool)+ srcBreakthroughCounterHandler _ SourceBreakpointInfo {+ srcBPSourceBreakpointInfo = D.SourceBreakpoint {+ D.hitConditionSourceBreakpoint = Nothing+ }+ } = return Nothing+ srcBreakthroughCounterHandler no bpInfo@SourceBreakpointInfo {+ srcBPSourceBreakpointInfo = D.SourceBreakpoint {+ D.hitConditionSourceBreakpoint = Just condStr+ }+ , hitCntSourceBreakpointInfo = curCnt} = do+ let newCnt = curCnt + 1+ stmt = if L.isInfixOf "_CNT" condStr + then "let _CNT = " ++ show newCnt ++ " in " ++ condStr+ else "let _CNT = " ++ show newCnt ++ " in _CNT " ++ condStr++ liftIO $ updateSrcBreakCounter no bpInfo{hitCntSourceBreakpointInfo = newCnt}++ runStmtDAP mvarCtx False stmt >>= \case+ Left err -> do+ liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err+ return $ Just False+ Right res -> do+ liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result. " ++ stmt ++ " -> " ++ show res+ return $ Just ("False" == D.resultEvaluateBody res)++ -- |+ --+ updateSrcBreakCounter no bpInfo = do+ ctx <- takeMVar mvarCtx+ let cur = srcBPsDAPContext ctx+ new = M.insert no bpInfo cur+ putMVar mvarCtx ctx{srcBPsDAPContext = new}+++ -- |+ --+ funcBreakthroughCounterHandler :: Int -> (D.FunctionBreakpoint, Int) -> GHCi.GHCi (Maybe Bool)+ funcBreakthroughCounterHandler _ (D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Nothing}, _) = return Nothing+ funcBreakthroughCounterHandler no info@(D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Just condStr}, curCnt) = do+ let newCnt = curCnt + 1+ stmt = if L.isInfixOf "_CNT" condStr + then "let _CNT = " ++ show newCnt ++ " in " ++ condStr+ else "let _CNT = " ++ show newCnt ++ " in _CNT " ++ condStr++ liftIO $ updateFuncBreakCounter no (fst info, newCnt)++ runStmtDAP mvarCtx False stmt >>= \case+ Left err -> do+ liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err+ return $ Just False+ Right res -> do+ when ("Bool" /= D.typeEvaluateBody res) $+ liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res+ return $ Just ("False" == D.resultEvaluateBody res)+++ -- |+ --+ updateFuncBreakCounter no bpInfo = do+ ctx <- takeMVar mvarCtx+ let cur = funcBPsDAPContext ctx+ new = M.insert no bpInfo cur+ putMVar mvarCtx ctx{funcBPsDAPContext = new}++ -- |+ -- @return+ -- True -> breakthrough+ -- False -> break+ --+ breakthroughCondtionHandler :: Int -> Maybe String -> GHCi.GHCi (Maybe Bool)+ breakthroughCondtionHandler _ Nothing = return Nothing+ breakthroughCondtionHandler no (Just stmt) = runStmtDAP mvarCtx False stmt >>= \case+ Left err -> do+ liftIO $ putStrLn $ "[DAP][ERROR] condition statement fail. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ err+ return $ Just False+ Right res -> do+ when ("Bool" /= D.typeEvaluateBody res) $+ liftIO $ putStrLn $ "[DAP][ERROR] condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res+ return $ Just ("False" == D.resultEvaluateBody res)++ -- |+ -- @return+ -- must be True -> breakthrough+ -- + logPointHandler :: Int -> Maybe String -> GHCi.GHCi (Maybe Bool)+ logPointHandler _ Nothing = return Nothing+ logPointHandler no (Just stmt) = do+ runStmtDAP mvarCtx False stmt >>= \case+ Left err -> do+ let msg = "[DAP][ERROR] logpoint evaluate statement error at BPNO:" ++ show no ++ " error:" ++ err+ body = D.defaultOutputEventBody { D.outputOutputEventBody = msg+ , D.categoryOutputEventBody = "stderr" }+ printOutputEventDAP (Right body)+ return $ Just False++ Right res -> do+ let msg = D.resultEvaluateBody res ++ "\n"+ body = D.defaultOutputEventBody { D.outputOutputEventBody = msg+ , D.categoryOutputEventBody = "console"}++ printOutputEventDAP (Right body)+ return $ Just True+++-- |+--+withExecResult :: MVar DAPContext -> String-> GHC.ExecResult -> GHCi.GHCi (Either String D.StoppedEventBody)+withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Right _ }) = do+ return $ Right D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "complete"+ }+ +withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Left (SomeException e)}) = do+ return $ Right D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "complete"+ , D.descriptionStoppedEventBody = show e+ , D.textStoppedEventBody = show e+ }++withExecResult _ reason (GHC.ExecBreak{GHC.breakInfo = Just (BreakInfo _ _)}) = do+ -- liftIO $ putStrLn $ "[DAP][DEBUG] " ++ GHC.moduleNameString (GHC.moduleName m)+ -- liftIO $ putStrLn $ "[DAP][DEBUG] " ++ show n+ return $ Right D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = reason+ }++withExecResult mvarCtx _ (GHC.ExecBreak{GHC.breakInfo = Nothing}) = do+ let key = "_exception"+ --runStmtDAP mvarCtx False key >>= \case+ gcatch (GHC.parseName key) parseNameErrorHandler >>= names2EvalBody mvarCtx False key >>= \case+ Left msg -> return $ Left $ "[DAP][ERROR] invalid _exception result." ++ msg+ Right body -> return $ Right D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "exception"+ , D.descriptionStoppedEventBody = D.resultEvaluateBody body+ , D.textStoppedEventBody = D.resultEvaluateBody body+ }++{-do+ evalBody <- getEvalBody "_exception" True+ return $ Right D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "exception"+ , D.descriptionStoppedEventBody = D.resultEvaluateBody evalBody+ , D.textStoppedEventBody = D.resultEvaluateBody evalBody+ }+ -}+++++------------------------------------------------------------------------------------------------+-- DAP Command :dap-next+------------------------------------------------------------------------------------------------++-- |+--+dapNextCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapNextCommand mvarCtx argsStr = do+ res <- withArgs (readDAP argsStr)+ printDAP res++ where+ withArgs :: Either String D.NextArguments -> GHCi.GHCi (Either String D.StoppedEventBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right _) = do+ clearTmpDAPContext++ GHCi.stepLocalCmd ""++ ctx <- liftIO $ readMVar mvarCtx+ withResults $ doContinueExecResultDAPContext ctx+++ -- |+ --+ withResults [] = return $ Left $ "[DAP][ERROR] invalid stepLocalCmd result."+ withResults (res:[]) = withExecResult mvarCtx "step" res+ withResults (res:_) = do+ liftIO $ putStrLn $ "[DAP][WARN] two or more stepLocalCmd results. use first result. "+ withExecResult mvarCtx "step" res+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-step-in+------------------------------------------------------------------------------------------------++-- |+--+dapStepInCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapStepInCommand mvarCtx argsStr = do+ res <- withArgs (readDAP argsStr)+ printDAP res+ + where+ withArgs :: Either String D.StepInArguments -> GHCi.GHCi (Either String D.StoppedEventBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right _) = do+ clearTmpDAPContext++ GHCi.stepCmd ""++ ctx <- liftIO $ readMVar mvarCtx+ withResults $ doContinueExecResultDAPContext ctx+++ -- |+ --+ withResults [] = return $ Left $ "[DAP][ERROR] invalid stepCmd result."+ withResults (res:[]) = withExecResult mvarCtx "step" res+ withResults (res:_) = do+ liftIO $ putStrLn $ "[DAP][WARN] two or more stepCmd results. use first result. "+ withExecResult mvarCtx "step" res+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-stacktrace+------------------------------------------------------------------------------------------------++-- |+--+dapStackTraceCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapStackTraceCommand ctxMVar argsStr = do+ + ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {frameIdDAPContext = 0}++ res <- withArgs (readDAP argsStr) + printDAP res+ + where+ withArgs :: Either String D.StackTraceArguments -> GHCi.GHCi (Either String D.StackTraceBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right _) = GHC.getResumeContext >>= \case+ [] -> return $ Left "no stacktrace found."+ (r:_) -> withResume r++ withResume r = case isExceptionResume r of+ True -> do+ dflags <- GHCi.getDynFlags+ let maxSize = GHC.ghciHistSize dflags+ -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize++ traces <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r++ return $ Right D.defaultStackTraceBody {+ D.stackFramesStackTraceBody = traces+ , D.totalFramesStackTraceBody = length traces+ }+ False -> do+ dflags <- GHCi.getDynFlags+ let start = resume2stackframe r+ maxSize = (GHC.ghciHistSize dflags) - 1+ -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize++ hists <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r+ + let traces = start : hists++ return $ Right D.defaultStackTraceBody {+ D.stackFramesStackTraceBody = traces+ , D.totalFramesStackTraceBody = length traces+ }++ resume2stackframe r = D.defaultStackFrame {+ D.idStackFrame = 0+ , D.nameStackFrame = (getStackFrameTitle r)+ , D.sourceStackFrame = D.defaultSource {+ D.pathSource = getSrcPath (GHC.resumeSpan r)+ }+ , D.lineStackFrame = getStartLinet (GHC.resumeSpan r)+ , D.columnStackFrame = getStartCol (GHC.resumeSpan r)+ , D.endLineStackFrame = getEndLinet (GHC.resumeSpan r)+ , D.endColumnStackFrame = getEndCol (GHC.resumeSpan r)+ }+ + getStackFrameTitle r = maybe "unknown" (GHC.moduleNameString . GHC.moduleName . GHC.breakInfo_module) (GHC.resumeBreakInfo r)+ ++ "."+ ++ GHC.resumeDecl r++ getSrcPath (GHC.RealSrcSpan dat) = (unpackFS . GHC.srcSpanFile) dat+ getSrcPath (GHC.UnhelpfulSpan _) = "UnhelpfulSpan"++ getStartLinet (GHC.RealSrcSpan dat) = GHC.srcSpanStartLine dat+ getStartLinet (GHC.UnhelpfulSpan _) = 0++ getStartCol (GHC.RealSrcSpan dat) = GHC.srcSpanStartCol dat+ getStartCol (GHC.UnhelpfulSpan _) = 0++ getEndLinet (GHC.RealSrcSpan dat) = GHC.srcSpanEndLine dat+ getEndLinet (GHC.UnhelpfulSpan _) = 0++ getEndCol (GHC.RealSrcSpan dat) = GHC.srcSpanEndCol dat+ getEndCol (GHC.UnhelpfulSpan _) = 0++ resumeHist2stackFrame hist = do+ span <- GHC.getHistorySpan hist+ return D.defaultStackFrame {+ D.idStackFrame = 0+ , D.nameStackFrame = L.intercalate ":" (GHC.historyEnclosingDecls hist)+ , D.sourceStackFrame = D.defaultSource {+ D.pathSource = getSrcPath span+ }+ , D.lineStackFrame = getStartLinet span+ , D.columnStackFrame = getStartCol span+ , D.endLineStackFrame = getEndLinet span+ , D.endColumnStackFrame = getEndCol span+ }+ +++------------------------------------------------------------------------------------------------+-- DAP Command :dap-variables+------------------------------------------------------------------------------------------------++-- |+--+dapVariablesCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapVariablesCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ withArgs :: Either String D.VariablesArguments -> GHCi.GHCi (Either String D.VariablesBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = do+ let idx = D.variablesReferenceVariablesArguments args++ vals <- getBindingVariables ctxMVar idx++ return $ Right $ D.VariablesBody $ L.sortBy compName vals++ compName a b = compare (D.nameVariable a) (D.nameVariable b)++-- |+--+getBindingVariables :: MVar DAPContext -> Int -> GHCi.GHCi [D.Variable]+getBindingVariables ctx idx+ | 1 == idx = getBindingVariablesLocal ctx + | 2 == idx = getBindingVariablesGlobal ctx + | otherwise = getBindingVariablesNode ctx idx+++-- |+--+getBindingVariablesLocal :: MVar DAPContext -> GHCi.GHCi [D.Variable]+getBindingVariablesLocal ctxMVar = do+ bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar+ getBindingVariablesRoot ctxMVar bindings+++-- |+--+getBindingVariablesGlobal :: MVar DAPContext -> GHCi.GHCi [D.Variable]+getBindingVariablesGlobal ctxMVar = do+ bindings <- liftIO $ bindingGlobalDAPContext <$> readMVar ctxMVar+ getBindingVariablesRoot ctxMVar bindings+ ++-- |+--+getBindingVariablesRoot :: MVar DAPContext -> [GHC.TyThing] -> GHCi.GHCi [D.Variable]+getBindingVariablesRoot ctxMVar bindings = do+ -- bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar+ -- liftIO $ putStrLn $ "[DAP][INFO] bindings " ++ show (length bindings)++ foldM go [] bindings+ --mapM tyThing2Val bindings++ where+ go acc ty = gcatch (doSomething acc ty) (onError acc)+ doSomething acc ty = do+ v <- tyThing2Val ty+ return (v:acc)+ onError :: [D.Variable] -> SomeException -> GHCi.GHCi [D.Variable]+ onError acc e = do+ liftIO $ putStrLn $ "[DAP][DEBUG] ERROR: " ++ (show e)+ return acc+ + -- |+ -- TyThings https://hackage.haskell.org/package/ghc-8.2.1/docs/HscTypes.html#t:TyThing+ --+ tyThing2Val :: GHC.TyThing -> GHCi.GHCi D.Variable+ tyThing2Val (AnId i) = do+ let isForce = True+ depth = _BINDING_INSPECT_DEPTH+ + GHC.obtainTermFromId depth isForce i >>= withTerm i+ + tyThing2Val t@(ATyCon c) = do+ dflags <- getDynFlags+ return D.defaultVariable {+ D.nameVariable = showSDoc dflags (ppr t)+ , D.typeVariable = showSDoc dflags (ppr c)+ , D.valueVariable = "<define>"+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }+ + tyThing2Val t@(AConLike c) = do+ dflags <- getDynFlags+ return D.defaultVariable {+ D.nameVariable = showSDoc dflags (ppr t)+ , D.typeVariable = showSDoc dflags (ppr c)+ , D.valueVariable = "<define>"+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }+ + tyThing2Val x = do+ dflags <- getDynFlags+ return D.defaultVariable {+ D.nameVariable = showSDoc dflags (ppr x)+ , D.typeVariable = "not yet supported tything."+ , D.valueVariable = "not yet supported tything."+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }++ -- |+ -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html+ --+ withTerm :: GHC.Id -> Term -> GHCi.GHCi D.Variable+ withTerm i t@(Term ty _ _ _) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm t) showTermErrorHandler+ let nameStr = showSDoc dflags (ppr i)+ typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ nextIdx <- getNextIdx ctxMVar t nameStr+ + return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = valStr+ , D.evaluateNameVariable = Just nameStr+ , D.variablesReferenceVariable = nextIdx+ }++ withTerm i _ = do+ dflags <- getDynFlags+ idSDoc <- pprTypeAndContents i++ let (nameStr, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc)+ {-+ let nameStr = takeWhile (/= ' ') $ showSDoc dflags idSDoc+ typeStr = showSDoc dflags idSDoc+ valStr = "<define>"+ -}++ return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = valStr+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }+++-- |+--+getNextIdx :: MVar DAPContext -> Term -> String -> GHCi.GHCi Int+getNextIdx ctxMVar t@(Term ty _ _ subTerms) str = getDynFlags >>= withDynFlags+ where+ withDynFlags dflags + | 0 == length subTerms = return 0+ | 1 == length subTerms && isPrim (head subTerms) = return 0+ | "[Char]" == showSDoc dflags (pprTypeForUser ty) = return 0+ | "String" == showSDoc dflags (pprTypeForUser ty) = return 0+ | otherwise = liftIO $ addTerm2VariableReferenceMap ctxMVar t str++getNextIdx ctxMVar t str = liftIO $ addTerm2VariableReferenceMap ctxMVar t str+++-- |+--+addTerm2VariableReferenceMap :: MVar DAPContext -> Term -> String -> IO Int+addTerm2VariableReferenceMap ctxMVar t str = do+ ctx <- takeMVar ctxMVar+ let curMap = variableReferenceMapDAPContext ctx+ nextId = (M.size curMap) + 10++ putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap}++ return nextId+++-- |+--+getDataConstructor :: Term -> GHCi.GHCi String+getDataConstructor (Term _ (Left dc) _ _) = return dc+getDataConstructor (Term _ (Right dc) _ _) = do+ dflags <- getDynFlags+ let conStr = if isTupleDataCon dc then "Tuple" else showSDoc dflags $ ppr $ dataConName dc+ conStr' = if ":" == conStr then "List" else conStr+ typeStr = showSDoc dflags (pprTypeForUser (dataConRepType dc))+ return $ conStr' ++ " :: " ++ typeStr+getDataConstructor _ = return "[getDataConstructor] not supported type."++++-- |+--+getBindingVariablesNode :: MVar DAPContext -> Int -> GHCi.GHCi [D.Variable]+getBindingVariablesNode ctxMVar idx = do+ ctx <- liftIO $ readMVar ctxMVar+ case M.lookup idx (variableReferenceMapDAPContext ctx) of+ Just (t, str) -> withTerm t str+ Nothing -> do+ liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] id not found. " ++ show idx+ return []++ where+ withTerm (Term _ (Right dc) _ subTerms) str = do+ let labels = if 0 == length (dataConFieldLabels dc)+ then map (\i->"_" ++ show i) [1..(length subTerms)]+ else map (unpackFS . flLabel) (dataConFieldLabels dc)+ mapM (withSubTerm str) $ zip labels subTerms++ withTerm (Term _ (Left _) _ subTerms) str = do+ let labels = map (\i->"_" ++ show i) [1..(length subTerms)]+ mapM (withSubTerm str) $ zip labels subTerms++ withTerm _ _ = do+ liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] invalid map term type. " ++ show idx+ return []++ withSubTerm evalStr (label, t@(Term ty _ _ _)) = do+ -- liftIO $ putStrLn $ "[DEBUG]" ++ " subTerms. [" ++ show (length subTerms) ++ "]"+ termSDoc <- gcatch (showTerm t) showTermErrorHandler+ dflags <- getDynFlags++ let nameStr = label+ typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ nextIdx <- getNextIdx ctxMVar t evalStr+ valStr' <- if 0 == nextIdx then return valStr+ else getDataConstructor t+ return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = valStr'+ , D.evaluateNameVariable = Just evalStr+ , D.variablesReferenceVariable = nextIdx+ }+ withSubTerm evalStr (label, (Prim ty val)) = do+ dflags <- getDynFlags+ return D.defaultVariable {+ D.nameVariable = label+ , D.typeVariable = showSDoc dflags (pprTypeForUser ty)+ , D.valueVariable = showSDoc dflags (ppr val)+ , D.evaluateNameVariable = Just evalStr+ , D.variablesReferenceVariable = 0+ }+ withSubTerm evalStr (label, (Suspension _ ty _ _)) = do+ dflags <- getDynFlags+ return D.defaultVariable {+ D.nameVariable = label+ , D.typeVariable = showSDoc dflags (pprTypeForUser ty)+ , D.valueVariable = "function :: " ++ showSDoc dflags (pprTypeForUser ty)+ , D.evaluateNameVariable = Just evalStr+ , D.variablesReferenceVariable = 0+ }+ withSubTerm evalStr (label, _) = return D.defaultVariable {+ D.nameVariable = label+ , D.typeVariable = "not supported subTerm."+ , D.valueVariable = "not supported subTerm."+ , D.evaluateNameVariable = Just evalStr+ , D.variablesReferenceVariable = 0+ }++------------------------------------------------------------------------------------------------+-- DAP Command :dap-evaluate+------------------------------------------------------------------------------------------------++-- |+--+dapEvaluateCommand :: MVar DAPContext -> String -> GHCi.GHCi ()+dapEvaluateCommand ctxMVar argsStr = do+ res <- withArgs (readDAP argsStr) + printDAP res++ where+ -- |+ --+ withArgs :: Either String D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody)+ withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr+ withArgs (Right args) = case D.contextEvaluateArguments args of+ Nothing -> runRepl args+ Just "repl" -> runRepl args+ _ -> runOther args++ -- |+ --+ runRepl :: D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody)+ runRepl args+ | null (D.expressionEvaluateArguments args) = return $ Right D.defaultEvaluateBody {+ D.resultEvaluateBody = "no input."+ , D.typeEvaluateBody = "no input."+ , D.variablesReferenceEvaluateBody = 0+ }+ | otherwise = do+ let stmt = D.expressionEvaluateArguments args+ isRefable = True++ runStmtDAP ctxMVar isRefable stmt++ -- |+ --+ runOther :: D.EvaluateArguments -> GHCi.GHCi (Either String D.EvaluateBody)+ runOther args = do + let nameStr = D.expressionEvaluateArguments args+ names <- gcatch (GHC.parseName nameStr) parseNameErrorHandler+ names2EvalBody ctxMVar True nameStr names+++-- |+--+runStmtDAP :: MVar DAPContext -> Bool -> String -> GHCi.GHCi (Either String D.EvaluateBody)+runStmtDAP ctxMVar isRefable stmt = do+ clearTmpDAPContext++ GHCi.runStmt stmt GHC.RunToCompletion >>= \case+ Nothing -> Left <$> getRunStmtSourceError+ Just (GHC.ExecBreak _ Nothing) -> return $ Left $ "unexpected break occured while evaluating stmt:" ++ stmt+ Just (GHC.ExecBreak _ (Just (BreakInfo (GHC.Module _ modName) idx))) -> do+ let modStr = GHC.moduleNameString modName+ return $ Left $ "unexpected break occured. breakNo:" ++ show idx+ ++ " in " ++ modStr ++ " while evaluating stmt:" ++ stmt+ Just (GHC.ExecComplete (Left msg) _) -> return $ Left $ "runStmt error. " ++ show msg+ Just (GHC.ExecComplete (Right names) _) -> names2EvalBody ctxMVar isRefable stmt names+ ++-- |+--+--+names2EvalBody :: MVar DAPContext -> Bool -> String -> [GHC.Name] -> GHCi.GHCi (Either String D.EvaluateBody)+names2EvalBody ctxMVar isRefable key names+ | 0 == length names = return $ Left $ "Not in scope. " ++ key+ | 1 == length names = withName $ head names+ | otherwise = return $ Left $ "Ambiguous name. " ++ key++ where+ withName n = GHC.lookupName n >>= \case+ Nothing -> return $ Left $ "TyThing not found. " ++ key+ Just ty -> withTyThing ty++ withTyThing (AnId i) = do+ let isForce = True+ depth = _EVALUATE_INSPECT_DEPTH+ body <- GHC.obtainTermFromId depth isForce i >>= withTerm i+ return $ Right body++ withTyThing x = do+ liftIO $ putStrLn "[DAP][INFO] withTyThing x Not yet supported."+ dflags <- getDynFlags+ return $ Right D.defaultEvaluateBody {+ D.resultEvaluateBody = showSDoc dflags (ppr x)+ , D.typeEvaluateBody = showSDoc dflags (ppr x)+ , D.variablesReferenceEvaluateBody = 0+ }++ -- |+ -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html+ --+ withTerm :: GHC.Id -> Term -> GHCi.GHCi D.EvaluateBody+ withTerm _ t@(Term ty _ _ _) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm t) showTermErrorHandler+ let typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ nextIdx <- if True == isRefable then getNextIdx ctxMVar t key else return 0+ valStr' <- if 0 == nextIdx then return valStr+ else getDataConstructor t++ -- liftIO $ putStrLn "[DAP][INFO] Term Not yet supported."++ return D.defaultEvaluateBody {+ D.resultEvaluateBody = delDQ typeStr valStr'+ , D.typeEvaluateBody = typeStr+ , D.variablesReferenceEvaluateBody = nextIdx+ }++ withTerm _ t@(Prim ty _) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm t) showTermErrorHandler+ let typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ -- liftIO $ putStrLn "[DAP][INFO] Prim Not yet supported."++ return D.defaultEvaluateBody {+ D.resultEvaluateBody = valStr+ , D.typeEvaluateBody = typeStr+ , D.variablesReferenceEvaluateBody = 0+ }++ withTerm _ t@(Suspension clsr ty _ _) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm t) showTermErrorHandler+ let typeStr = "closure(" ++ show clsr ++ ")" ++ " :: " ++ showSDoc dflags (pprTypeForUser ty) ++ " # " ++ showSDoc dflags termSDoc++ liftIO $ putStrLn "[DAP][INFO] Suspension Not yet supported."+ return D.defaultEvaluateBody {+ D.resultEvaluateBody = typeStr+ , D.typeEvaluateBody = typeStr+ , D.variablesReferenceEvaluateBody = 0+ }++ withTerm _ (NewtypeWrap ty _ wt) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm wt) showTermErrorHandler+ let typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ liftIO $ putStrLn "[DAP][INFO] NewtypeWrap Not yet supported."+ return D.defaultEvaluateBody {+ D.resultEvaluateBody = valStr+ , D.typeEvaluateBody = typeStr+ , D.variablesReferenceEvaluateBody = 0+ }++ withTerm _ (RefWrap ty wt) = do+ dflags <- getDynFlags+ termSDoc <- gcatch (showTerm wt) showTermErrorHandler+ let typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc++ liftIO $ putStrLn "[DAP][INFO] RefWrap Not yet supported."+ return D.defaultEvaluateBody {+ D.resultEvaluateBody = valStr+ , D.typeEvaluateBody = typeStr+ , D.variablesReferenceEvaluateBody = 0+ }++ delDQ :: String -> String -> String+ delDQ typ val+ | (typ == "[Char]" || typ == "String")+ && length val > 2+ && head val == '"' && last val == '"' = tail $ init val + | otherwise = val+
app/Haskell/DAP/GHCi/Constant.hs view
@@ -1,38 +1,38 @@-module Haskell.DAP.GHCi.Constant where - - --- | --- -_DAP_HEADER :: String -_DAP_HEADER = "<<DAP>>" - - --- | --- -_DAP_CMD_END :: String -_DAP_CMD_END = "<<DAP_CMD_END>>" - --- | --- -_DAP_HEADER_OUTPUT_EVENT :: String -_DAP_HEADER_OUTPUT_EVENT = "<<DAP_OUTPUT_EVENT>>" - --- | --- -_GHCi_SCOPE :: String -_GHCi_SCOPE = "GHCi Local" - --- | --- -_GHCi_GLOBAL_SCOPE :: String -_GHCi_GLOBAL_SCOPE = "GHCi Global" - --- | --- -_BINDING_INSPECT_DEPTH :: Int -_BINDING_INSPECT_DEPTH = 100 - --- | --- -_EVALUATE_INSPECT_DEPTH :: Int +module Haskell.DAP.GHCi.Constant where++ +-- |+--+_DAP_HEADER :: String+_DAP_HEADER = "<<DAP>>"+++-- |+--+_DAP_CMD_END :: String+_DAP_CMD_END = "<<DAP_CMD_END>>"++-- |+--+_DAP_HEADER_OUTPUT_EVENT :: String+_DAP_HEADER_OUTPUT_EVENT = "<<DAP_OUTPUT_EVENT>>"++-- |+--+_GHCi_SCOPE :: String+_GHCi_SCOPE = "GHCi Local"+ +-- |+--+_GHCi_GLOBAL_SCOPE :: String+_GHCi_GLOBAL_SCOPE = "GHCi Global"+ +-- |+--+_BINDING_INSPECT_DEPTH :: Int+_BINDING_INSPECT_DEPTH = 100++-- |+--+_EVALUATE_INSPECT_DEPTH :: Int _EVALUATE_INSPECT_DEPTH = 1000
app/Haskell/DAP/GHCi/Type.hs view
@@ -1,66 +1,66 @@-module Haskell.DAP.GHCi.Type where - -import qualified GHC -import RtClosureInspect - -import qualified Data.Map as M -import Control.Concurrent -import HscTypes - -import qualified GHCi.DAP.IFData as D - - --- | --- -type EvalString = String - - --- | --- -type ModuleName = String - - --- | --- -type MVarDAPContext = MVar DAPContext - --- | --- -data SourceBreakpointInfo = SourceBreakpointInfo { - modNameSourceBreakpointInfo :: ModuleName - , srcBPSourceBreakpointInfo :: D.SourceBreakpoint - , hitCntSourceBreakpointInfo :: Int - } deriving (Show, Read, Eq) - - --- | --- -data DAPContext = DAPContext { - variableReferenceMapDAPContext :: M.Map Int (Term, EvalString) - , bindingDAPContext :: [GHC.TyThing] - , bindingGlobalDAPContext :: [GHC.TyThing] - , frameIdDAPContext :: Int - , srcBPsDAPContext :: M.Map Int SourceBreakpointInfo - , funcBPsDAPContext :: M.Map Int (D.FunctionBreakpoint, Int) - , traceCmdExecResultDAPContext :: [Maybe GHC.ExecResult] - , doContinueExecResultDAPContext :: [GHC.ExecResult] - , runStmtDeclExceptionDAPContext :: [SourceError] - } - - --- | --- -defaultDAPContext :: DAPContext -defaultDAPContext = DAPContext { - variableReferenceMapDAPContext = M.fromList [] - , bindingDAPContext = [] - , bindingGlobalDAPContext = [] - , frameIdDAPContext = 0 - , srcBPsDAPContext = M.fromList [] - , funcBPsDAPContext = M.fromList [] - , traceCmdExecResultDAPContext = [] - , doContinueExecResultDAPContext = [] - , runStmtDeclExceptionDAPContext = [] - } - +module Haskell.DAP.GHCi.Type where++import qualified GHC+import RtClosureInspect++import qualified Data.Map as M+import Control.Concurrent+import HscTypes++import qualified GHCi.DAP.IFData as D+++-- |+--+type EvalString = String+++-- |+--+type ModuleName = String+++-- |+--+type MVarDAPContext = MVar DAPContext++-- |+--+data SourceBreakpointInfo = SourceBreakpointInfo {+ modNameSourceBreakpointInfo :: ModuleName+ , srcBPSourceBreakpointInfo :: D.SourceBreakpoint+ , hitCntSourceBreakpointInfo :: Int+ } deriving (Show, Read, Eq)+++-- |+--+data DAPContext = DAPContext {+ variableReferenceMapDAPContext :: M.Map Int (Term, EvalString)+ , bindingDAPContext :: [GHC.TyThing]+ , bindingGlobalDAPContext :: [GHC.TyThing]+ , frameIdDAPContext :: Int+ , srcBPsDAPContext :: M.Map Int SourceBreakpointInfo+ , funcBPsDAPContext :: M.Map Int (D.FunctionBreakpoint, Int)+ , traceCmdExecResultDAPContext :: [Maybe GHC.ExecResult]+ , doContinueExecResultDAPContext :: [GHC.ExecResult]+ , runStmtDeclExceptionDAPContext :: [SourceError]+ }++ +-- |+--+defaultDAPContext :: DAPContext+defaultDAPContext = DAPContext {+ variableReferenceMapDAPContext = M.fromList []+ , bindingDAPContext = []+ , bindingGlobalDAPContext = []+ , frameIdDAPContext = 0+ , srcBPsDAPContext = M.fromList []+ , funcBPsDAPContext = M.fromList []+ , traceCmdExecResultDAPContext = []+ , doContinueExecResultDAPContext = []+ , runStmtDeclExceptionDAPContext = []+ }+
app/Haskell/DAP/GHCi/Utility.hs view
@@ -1,189 +1,189 @@-{-# LANGUAGE LambdaCase #-} - -module Haskell.DAP.GHCi.Utility where - -import qualified GHC -import qualified GHCi.UI.Monad as G -import Outputable -import Exception - -import qualified Data.Char as CH -import qualified Data.ByteString as BS -import qualified Data.Text.Encoding as T -import qualified Data.Text as T -import qualified Data.List as L -import qualified Text.Read as R -import Data.Maybe -import Data.Word - -import Control.Monad.IO.Class -import Control.Concurrent - -import Haskell.DAP.GHCi.Constant -import Haskell.DAP.GHCi.Type - -import qualified GHCi.DAP.IFData as D - --- | --- -_SLASH :: Char -_SLASH = '/' - - --- | --- -_BACK_SLASH :: Char -_BACK_SLASH = '\\' - - --- | --- -_SPACES :: [Char] -_SPACES = [' ', '\n', '\t'] - - --- | --- -lstrip, rstrip, strip :: String -> String -lstrip = dropWhile (flip elem _SPACES) -rstrip = reverse . lstrip . reverse -strip = lstrip . rstrip - - --- | --- -toLower :: String -> String -toLower = map CH.toLower - - --- | --- -toUpper :: String -> String -toUpper = map CH.toUpper - - --- | --- -win2unixSlash :: String -> String -win2unixSlash = map (\c -> if c == _BACK_SLASH then _SLASH else c) - - --- | --- -unix2winSlash :: String -> String -unix2winSlash = map (\c -> if c == _SLASH then _BACK_SLASH else c) - - --- | --- normalized path --- -nzPath :: FilePath -> FilePath -nzPath = drive2lower . win2unixSlash - - --- | --- to lowercase Windows drive letter --- -drive2lower :: FilePath -> FilePath -drive2lower (x : ':' : xs) = CH.toLower x : ':' : xs -drive2lower xs = xs - - ------------------------------------------------------------------------------------------------- --- DAP Utility ------------------------------------------------------------------------------------------------- - --- | --- --- phoityne -> haskell-dap --- RequestArgument is encoded. decode to [Word8] --- -readDAP :: Read a => String -> Either String a -readDAP argsStr = case R.readEither argsStr :: Either String [Word8] of - Left err -> Left $ "read [Word8] failed. " ++ err ++ " : " ++ argsStr - Right bs -> case R.readEither (toStr bs) of - Left err -> Left $ "read response body failed. " ++ err ++ " : " ++ (toStr bs) - Right a -> Right a - where - toStr = T.unpack . T.decodeUtf8 . BS.pack - - --- | --- --- haskell-dap -> phoityne --- Just show ResponseBody. no need to encode to [Word8] --- -showDAP :: Show a => a -> String -showDAP = show - - --- | --- -printDAP :: Show a => a -> G.GHCi () -printDAP dat = do - let outStr = _DAP_HEADER ++ showDAP dat - - liftIO $ putStrLn outStr - --- | --- -printOutputEventDAP :: (Either String D.OutputEventBody) -> G.GHCi () -printOutputEventDAP dat = do - let outStr = _DAP_HEADER_OUTPUT_EVENT ++ showDAP dat - - liftIO $ putStrLn outStr - - --- | --- -clearTmpDAPContext :: G.GHCi () -clearTmpDAPContext = do - mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState - - ctx <- liftIO $ takeMVar mvarCtx - liftIO $ putMVar mvarCtx ctx{ - traceCmdExecResultDAPContext = [] - , doContinueExecResultDAPContext = [] - , runStmtDeclExceptionDAPContext = [] - } - - --- | --- -isExceptionResume :: GHC.Resume -> Bool -isExceptionResume (GHC.Resume{GHC.resumeBreakInfo = a}) = isNothing a - - --- | --- -parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name] -parseNameErrorHandler e = liftIO $ print e >> return [] - - --- | --- -showTermErrorHandler :: SomeException -> G.GHCi SDoc -showTermErrorHandler e = return $ text $ show e - --- | --- -getNameTypeValue :: String -> (String, String, String) -getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr) - where - nameStr = head $ words str - typeStr = unwords $ takeWhile ((/=)"=") $ tail $ tail $ words str - valueStr = unwords $ tail $ dropWhile ((/=)"=") $ words str - --- | --- -getRunStmtSourceError :: G.GHCi String -getRunStmtSourceError = do - mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState - - ctx <- liftIO $ readMVar mvarCtx - let errs = runStmtDeclExceptionDAPContext ctx - msgs = "[DAP][ERROR] error occurred while runStmt." - : map show errs - - return $ L.intercalate "\n" msgs +{-# LANGUAGE LambdaCase #-}++module Haskell.DAP.GHCi.Utility where++import qualified GHC+import qualified GHCi.UI.Monad as G+import Outputable+import Exception++import qualified Data.Char as CH+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import qualified Data.List as L+import qualified Text.Read as R+import Data.Maybe+import Data.Word++import Control.Monad.IO.Class+import Control.Concurrent++import Haskell.DAP.GHCi.Constant+import Haskell.DAP.GHCi.Type++import qualified GHCi.DAP.IFData as D++-- |+--+_SLASH :: Char+_SLASH = '/'+++-- |+--+_BACK_SLASH :: Char+_BACK_SLASH = '\\'+++-- |+--+_SPACES :: [Char]+_SPACES = [' ', '\n', '\t']+++-- |+--+lstrip, rstrip, strip :: String -> String+lstrip = dropWhile (flip elem _SPACES)+rstrip = reverse . lstrip . reverse+strip = lstrip . rstrip+++-- |+--+toLower :: String -> String+toLower = map CH.toLower+++-- |+--+toUpper :: String -> String+toUpper = map CH.toUpper+++-- |+--+win2unixSlash :: String -> String+win2unixSlash = map (\c -> if c == _BACK_SLASH then _SLASH else c)+++-- |+--+unix2winSlash :: String -> String+unix2winSlash = map (\c -> if c == _SLASH then _BACK_SLASH else c)+++-- |+-- normalized path+--+nzPath :: FilePath -> FilePath+nzPath = drive2lower . win2unixSlash+++-- |+-- to lowercase Windows drive letter +-- +drive2lower :: FilePath -> FilePath+drive2lower (x : ':' : xs) = CH.toLower x : ':' : xs+drive2lower xs = xs+++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+-- phoityne -> haskell-dap+-- RequestArgument is encoded. decode to [Word8]+--+readDAP :: Read a => String -> Either String a+readDAP argsStr = case R.readEither argsStr :: Either String [Word8] of+ Left err -> Left $ "read [Word8] failed. " ++ err ++ " : " ++ argsStr+ Right bs -> case R.readEither (toStr bs) of+ Left err -> Left $ "read response body failed. " ++ err ++ " : " ++ (toStr bs)+ Right a -> Right a + where+ toStr = T.unpack . T.decodeUtf8 . BS.pack+++-- |+--+-- haskell-dap -> phoityne+-- Just show ResponseBody. no need to encode to [Word8]+--+showDAP :: Show a => a -> String+showDAP = show+++-- |+--+printDAP :: Show a => a -> G.GHCi ()+printDAP dat = do+ let outStr = _DAP_HEADER ++ showDAP dat++ liftIO $ putStrLn outStr++-- |+--+printOutputEventDAP :: (Either String D.OutputEventBody) -> G.GHCi ()+printOutputEventDAP dat = do+ let outStr = _DAP_HEADER_OUTPUT_EVENT ++ showDAP dat++ liftIO $ putStrLn outStr+++-- |+--+clearTmpDAPContext :: G.GHCi ()+clearTmpDAPContext = do+ mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState ++ ctx <- liftIO $ takeMVar mvarCtx+ liftIO $ putMVar mvarCtx ctx{+ traceCmdExecResultDAPContext = []+ , doContinueExecResultDAPContext = []+ , runStmtDeclExceptionDAPContext = []+ }+++-- |+--+isExceptionResume :: GHC.Resume -> Bool+isExceptionResume (GHC.Resume{GHC.resumeBreakInfo = a}) = isNothing a+++-- |+--+parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name]+parseNameErrorHandler e = liftIO $ print e >> return []+++-- |+--+showTermErrorHandler :: SomeException -> G.GHCi SDoc+showTermErrorHandler e = return $ text $ show e++-- |+--+getNameTypeValue :: String -> (String, String, String)+getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr)+ where+ nameStr = head $ words str+ typeStr = unwords $ takeWhile ((/=)"=") $ tail $ tail $ words str + valueStr = unwords $ tail $ dropWhile ((/=)"=") $ words str ++-- |+--+getRunStmtSourceError :: G.GHCi String+getRunStmtSourceError = do+ mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState ++ ctx <- liftIO $ readMVar mvarCtx+ let errs = runStmtDeclExceptionDAPContext ctx+ msgs = "[DAP][ERROR] error occurred while runStmt." + : map show errs++ return $ L.intercalate "\n" msgs
app/Main.hs view
@@ -1,29 +1,29 @@-{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import qualified GHCMain as G -import qualified GHCi.UI as G -import Control.Concurrent -import Haskell.DAP.GHCi.Command -import Haskell.DAP.GHCi.Type - -import Paths_haskell_dap (version) -import Data.Version - --- | --- Main --- -main :: IO () -main = do - putStrLn $ "[DAP][INFO] start haskell-dap-" ++ showVersion version ++ "." - - mvarCtx <- newMVar defaultDAPContext - - let ghciSettings = G.defaultGhciSettings mvarCtx - defaultCommands = G.availableCommands ghciSettings - withDapCommands = defaultCommands ++ (dapCommands mvarCtx) - - G.ghcMain ghciSettings {G.availableCommands = withDapCommands} +{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified GHCMain as G+import qualified GHCi.UI as G+import Control.Concurrent+import Haskell.DAP.GHCi.Command+import Haskell.DAP.GHCi.Type++import Paths_haskell_dap (version)+import Data.Version++-- |+-- Main+--+main :: IO ()+main = do+ putStrLn $ "[DAP][INFO] start haskell-dap-" ++ showVersion version ++ "."++ mvarCtx <- newMVar defaultDAPContext++ let ghciSettings = G.defaultGhciSettings mvarCtx+ defaultCommands = G.availableCommands ghciSettings+ withDapCommands = defaultCommands ++ (dapCommands mvarCtx)++ G.ghcMain ghciSettings {G.availableCommands = withDapCommands}
haskell-dap.cabal view
@@ -4,18 +4,18 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6a622ca7c29d729489035a61fc25f874d847ffba2e7ca0e763404181ba1cd670+-- hash: b3a42e5025c9e19a3432a6cc79a7e3782a79bb1b2752afdccb6ec1f409a6fccb name: haskell-dap-version: 0.0.10.1-synopsis: haskell-dap is a GHCi having DAP interface.+version: 0.0.11.0+synopsis: Haskell implementation of the DAP interface data. description: Please see README.md category: Development homepage: https://github.com/phoityne/haskell-dap bug-reports: https://github.com/phoityne/haskell-dap/issues author: phoityne_hs maintainer: phoityne.hs@gmail.com-copyright: 2017-2018 phoityne_hs+copyright: 2017-2019 phoityne_hs license: BSD3 license-file: LICENSE build-type: Simple@@ -33,14 +33,15 @@ library exposed-modules:+ GHCi.DAP GHCi.DAP.IFData other-modules: Paths_haskell_dap hs-source-dirs: src- ghc-options: -Wall build-depends: base >=4.7 && <5+ , containers default-language: Haskell2010 executable haskell-dap@@ -53,7 +54,7 @@ Paths_haskell_dap hs-source-dirs: app- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing cpp-options: -DGHCI cc-options: -fPIC build-depends:
src-c-8.0/HsVersions.h view
@@ -1,52 +1,52 @@-#ifndef HSVERSIONS_H -#define HSVERSIONS_H - -#if 0 - -IMPORTANT! If you put extra tabs/spaces in these macro definitions, -you will screw up the layout where they are used in case expressions! - -(This is cpp-dependent, of course) - -#endif - -/* Useful in the headers that we share with the RTS */ -#define COMPILING_GHC 1 - -/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */ --- #include "ghc_boot_platform.h" - -/* Pull in the autoconf defines (HAVE_FOO), but don't include - * ghcconfig.h, because that will include ghcplatform.h which has the - * wrong platform settings for the compiler (it has the platform - * settings for the target plat instead). */ --- #include "../includes/ghcautoconf.h" - -#define GLOBAL_VAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.global (value); - -#define GLOBAL_VAR_M(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.globalM (value); - -#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else -#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else -#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ - --- Examples: Assuming flagSet :: String -> m Bool --- --- do { c <- getChar; MASSERT( isUpper c ); ... } --- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } --- do { str <- getStr; ASSERTM( flagSet str ); .. } --- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } --- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } -#define MASSERT(e) ASSERT(e) return () -#define MASSERT2(e,msg) ASSERT2(e,msg) return () -#define ASSERTM(e) do { bool <- e; MASSERT(bool) } -#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } -#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } - +#ifndef HSVERSIONS_H+#define HSVERSIONS_H++#if 0++IMPORTANT! If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+-- #include "ghc_boot_platform.h"++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+-- #include "../includes/ghcautoconf.h"++#define GLOBAL_VAR(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.globalM (value);++#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples: Assuming flagSet :: String -> m Bool+--+-- do { c <- getChar; MASSERT( isUpper c ); ... }+-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+-- do { str <- getStr; ASSERTM( flagSet str ); .. }+-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }+-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e) ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e) do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }+ #endif /* HsVersions.h */
+ src/GHCi/DAP.hs view
@@ -0,0 +1,2054 @@++{-|+Module : GHCi.DAP+Description : Implementation of DAP interface data type.+Copyright : 2017-2019 phoityne_hs+License : BSD3++Implementation of DAP interface data type.++@see : https://microsoft.github.io/debug-adapter-protocol/++@see : https://github.com/Microsoft/vscode-debugadapter-node/blob/master/protocol/src/debugProtocol.ts++-}+module GHCi.DAP (++ -- * commons+ _THREAD_ID+ , Request(..)+ , defaultRequest+ , Response(..)+ , ColumnDescriptor(..)+ , Source(..)+ , defaultSource+ , Breakpoint(..)+ , defaultBreakpoint+ , ExceptionBreakpointsFilter(..)++ -- * initialize+ , InitializeRequest(..)+ , defaultInitializeRequest+ , InitializeRequestArguments(..)+ , defaultInitializeRequestArguments+ , InitializeResponse(..)+ , defaultInitializeResponse+ , InitializeResponseBody(..)+ , defaultInitializeResponseBody+ + -- * disconnect+ , DisconnectRequest(..)+ , DisconnectRequestArguments(..)+ , DisconnectResponse(..)+ , defaultDisconnectResponse++ -- * pause+ , PauseRequest(..)+ , PauseRequestArguments(..)+ , PauseResponse(..)+ , defaultPauseResponse++ -- * terminate+ , TerminateRequest(..)+ , TerminateRequestArguments(..)+ , TerminateResponse(..)+ , defaultTerminateResponse++ -- * launch+ , LaunchRequest(..)+ , LaunchRequestArguments(..)+ , LaunchResponse(..)+ , defaultLaunchResponse++ -- * setBreakpoints+ , SourceBreakpoint(..)+ , SetBreakpointsRequest(..)+ , SetBreakpointsRequestArguments(..)+ , SetBreakpointsResponse(..)+ , SetBreakpointsResponseBody(..)+ , defaultSetBreakpointsResponse+ , defaultSetBreakpointsResponseBody++ -- * setFunctionBreakpoints+ , FunctionBreakpoint(..)+ , SetFunctionBreakpointsRequest(..)+ , SetFunctionBreakpointsRequestArguments(..)+ , SetFunctionBreakpointsResponse(..)+ , SetFunctionBreakpointsResponseBody(..)+ , defaultSetFunctionBreakpointsResponse++ -- * setExceptionBreakpoints+ , SetExceptionBreakpointsRequest(..)+ , SetExceptionBreakpointsRequestArguments(..)+ , SetExceptionBreakpointsResponse(..)+ , defaultSetExceptionBreakpointsResponse++ -- * configurationDone+ , ConfigurationDoneRequest(..)+ , ConfigurationDoneResponse(..)+ , defaultConfigurationDoneResponse++ -- * threads+ , ThreadsRequest(..)+ , defaultThreadsResponse+ , Thread(..)+ , ThreadsResponse(..)+ , ThreadsResponseBody(..)+ , defaultThreadsResponseBody++ -- * stackTrace+ , StackTraceRequest(..)+ , StackTraceRequestArguments(..)+ , StackFrame(..)+ , defaultStackFrame+ , StackTraceResponse(..)+ , defaultStackTraceResponse+ , StackTraceResponseBody(..)+ , defaultStackTraceResponseBody++ -- * scopes+ , ScopesRequest(..)+ , ScopesRequestArguments(..)+ , Scope(..)+ , defaultScope+ , ScopesResponse(..)+ , defaultScopesResponse+ , ScopesResponseBody(..)++ -- * variables+ , VariablesRequest(..)+ , VariablesRequestArguments(..)+ , Variable(..)+ , defaultVariable+ , VariablePresentationHint(..)+ , VariablesResponse(..)+ , defaultVariablesResponse+ , VariablesResponseBody(..)+ , defaultVariablesResponseBody++ -- * continue+ , ContinueRequest(..)+ , ContinueRequestArguments(..)+ , defaultContinueRequestArguments+ , ContinueResponse(..)+ , defaultContinueResponse++ -- * next+ , NextRequest(..)+ , NextRequestArguments(..)+ , NextResponse(..)+ , defaultNextResponse++ -- * stepIn+ , StepInRequest(..)+ , StepInRequestArguments(..)+ , StepInResponse(..)+ , defaultStepInResponse++ -- * evaluate+ , EvaluateRequest(..)+ , EvaluateRequestArguments(..)+ , EvaluateResponse(..)+ , defaultEvaluateResponse+ , EvaluateResponseBody(..)+ , defaultEvaluateResponseBody++ -- * completions+ , CompletionsRequest(..)+ , CompletionsRequestArguments(..)+ , CompletionsItem(..)+ , CompletionsResponse(..)+ , defaultCompletionsResponse+ , CompletionsResponseBody(..)+ , defaultCompletionsResponseBody++ -- * event+ , OutputEvent(..)+ , defaultOutputEvent+ , OutputEventBody(..)+ , defaultOutputEventBody++ , InitializedEvent(..)+ , defaultInitializedEvent++ , TerminatedEvent(..)+ , defaultTerminatedEvent+ , TerminatedEventBody(..)+ , defaultTerminatedEventBody++ , ExitedEvent(..)+ , defaultExitedEvent+ , ExitedEventBody(..)+ , defaultExitedEventBody++ , ContinuedEvent(..)+ , defaultContinuedEvent+ , ContinuedEventBody(..)+ , defaultContinuedEventBody++ , StoppedEvent(..)+ , defaultStoppedEvent+ , StoppedEventBody(..)+ , defaultStoppedEventBody++) where++import qualified Data.Map as M+++----------------------------------------------------------------------------+-- commons+----------------------------------------------------------------------------++-- |+-- The debugee thread id is fixed 0.+--+_THREAD_ID :: Int+_THREAD_ID = 0+++-- |+-- Client-initiated request+--+data Request =+ Request {+ seqRequest :: Int -- ^Sequence number. + , typeRequest :: String -- ^Message type. Values: 'request', 'response', 'event', etc.+ , commandRequest :: String -- ^The command to execute+ } deriving (Show, Read, Eq)+++-- |+--+defaultRequest :: Request+defaultRequest = Request {+ seqRequest = 0+ , typeRequest = "request"+ , commandRequest = ""+ } +++-- |+-- Response for a request.+--+data Response =+ Response {+ seqResponse :: Int -- ^Sequence number. + , typeResponse :: String -- ^Message type. Values: 'request', 'response', 'event', etc.+ , request_seqResponse :: Int -- ^Sequence number of the corresponding request.+ , successResponse :: Bool -- ^Outcome of the request. + , commandResponse :: String -- ^The command requested. + , messageResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+-- A ColumnDescriptor specifies what module attribute to show in a column of the ModulesView, +--+-- how to format it, and what the column's label should be.+--+-- It is only used if the underlying UI actually supports this level of customization.+--+data ColumnDescriptor =+ ColumnDescriptor {+ attributeNameColumnDescriptor :: String -- ^Name of the attribute rendered in this column. + , labelColumnDescriptor :: String -- ^Header UI label of column.+ , formatColumnDescriptor :: Maybe String -- ^Format to use for the rendered values in this column. TBD how the format strings looks like.+ , typeColumnDescriptor :: Maybe String -- ^Datatype of values in this column. Defaults to 'string' if not specified. 'string' | 'number' | 'boolean' | 'unixTimestampUTC';+ , widthColumnDescriptor :: Maybe Int -- ^Width of this column in characters (hint only).+ } deriving (Show, Read, Eq)+++-- |+-- A Source is a descriptor for source code.+--+-- It is returned from the debug adapter as part of a StackFrame and it is used by clients+--+-- when specifying breakpoints.+--+data Source =+ Source {+ nameSource :: Maybe String -- ^The short name of the source. Every source returned from the debug adapter has a name. When sending a source to the debug adapter this name is optional.+ , pathSource :: String -- ^The path of the source to be shown in the UI. It is only used to locate and load the content of the source if no sourceReference is specified (or its vaule is 0).+ , sourceReferenceSource :: Maybe Int -- ^If sourceReference > 0 the contents of the source must be retrieved through the SourceRequest (even if a path is specified). A sourceReference is only valid for a session, so it must not be used to persist a source.+ , origineSource :: Maybe String -- ^The (optional) origin of this source: possible values 'internal module', 'inlined content from source map', etc.+ } deriving (Show, Read, Eq)+++-- |+--+defaultSource :: Source+defaultSource = Source {+ nameSource = Nothing+ , pathSource = ""+ , sourceReferenceSource = Nothing+ , origineSource = Nothing+ }++++-- |+-- Information about a Breakpoint created in setBreakpoints or setFunctionBreakpoints.+--+data Breakpoint =+ Breakpoint {+ idBreakpoint :: Maybe Int -- ^An optional unique identifier for the breakpoint.+ , verifiedBreakpoint :: Bool -- ^If true breakpoint could be set (but not necessarily at the desired location).+ , messageBreakpoint :: String -- ^An optional message about the state of the breakpoint. This is shown to the user and can be used to explain why a breakpoint could not be verified.+ , sourceBreakpoint :: Source -- ^The source where the breakpoint is located.+ , lineBreakpoint :: Int -- ^The start line of the actual range covered by the breakpoint.+ , columnBreakpoint :: Int -- ^An optional start column of the actual range covered by the breakpoint.+ , endLineBreakpoint :: Int -- ^An optional end line of the actual range covered by the breakpoint.+ , endColumnBreakpoint :: Int -- ^An optional end column of the actual range covered by the breakpoint. If no end line is given, then the end column is assumed to be in the start line.+ } deriving (Show, Read, Eq)+++-- |+--+defaultBreakpoint :: Breakpoint+defaultBreakpoint = Breakpoint {+ idBreakpoint = Nothing+ , verifiedBreakpoint = False+ , messageBreakpoint = ""+ , sourceBreakpoint = defaultSource+ , lineBreakpoint = 0+ , columnBreakpoint = 0+ , endLineBreakpoint = 0+ , endColumnBreakpoint = 0+ }+++-- |+-- An ExceptionBreakpointsFilter is shown in the UI as an option for configuring how exceptions are dealt with.+--+data ExceptionBreakpointsFilter =+ ExceptionBreakpointsFilter {+ filterExceptionBreakpointsFilter :: String -- ^The internal ID of the filter. This value is passed to the setExceptionBreakpoints request.+ , labelExceptionBreakpointsFilter :: String -- ^The name of the filter. This will be shown in the UI.+ , defaultExceptionBreakpointsFilter :: Bool -- ^Initial value of the filter. If not specified a value 'false' is assumed.+ } deriving (Show, Read, Eq)+++----------------------------------------------------------------------------+-- Initialize+----------------------------------------------------------------------------++-- |+-- Initialize request; value of command field is 'initialize'.+--+-- The 'initialize' request is sent as the first request from the client to the debug adapter in order to configure it with client capabilities and to retrieve capabilities from the debug adapter.+--+-- Until the debug adapter has responded to with an 'initialize' response, the client must not send any additional requests or events to the debug adapter. In addition the debug adapter is not allowed to send any requests or events to the client until it has responded with an 'initialize' response.+--+-- The 'initialize' request may only be sent once.+--+data InitializeRequest =+ InitializeRequest {+ seqInitializeRequest :: Int -- ^Sequence number+ , typeInitializeRequest :: String -- ^One of "request", "response", or "event"+ , commandInitializeRequest :: String -- ^The command to execute+ , argumentsInitializeRequest :: InitializeRequestArguments -- ^Object containing arguments for the command+ } deriving (Show, Read, Eq)+++-- |+--+defaultInitializeRequest :: InitializeRequest+defaultInitializeRequest = InitializeRequest {+ seqInitializeRequest = 0+ , typeInitializeRequest = "request"+ , commandInitializeRequest = "initialize"+ , argumentsInitializeRequest = defaultInitializeRequestArguments+ }+++-- |+-- Arguments for 'initialize' request.+--+data InitializeRequestArguments =+ InitializeRequestArguments {+ adapterIDInitializeRequestArguments :: String -- ^The ID of the debugger adapter. Used to select or verify debugger adapter.+ , linesStartAt1InitializeRequestArguments :: Bool -- ^If true all line numbers are 1-based (default).+ , columnsStartAt1InitializeRequestArguments :: Bool -- ^If true all column numbers are 1-based (default).+ , pathFormatInitializeRequestArguments :: String -- ^Determines in what format paths are specified. Possible values are 'path' or 'uri'. The default is 'path', which is the native format.+ } deriving (Show, Read, Eq)+++-- |+--+defaultInitializeRequestArguments :: InitializeRequestArguments+defaultInitializeRequestArguments = InitializeRequestArguments {+ adapterIDInitializeRequestArguments = ""+ , linesStartAt1InitializeRequestArguments = False+ , columnsStartAt1InitializeRequestArguments = False+ , pathFormatInitializeRequestArguments = ""+ }+++-- |+-- Response to 'initialize' request.+--+data InitializeResponse =+ InitializeResponse {+ seqInitializeResponse :: Int -- ^Sequence number+ , typeInitializeResponse :: String -- ^One of "request", "response", or "event"+ , request_seqInitializeResponse :: Int -- ^Sequence number of the corresponding request+ , successInitializeResponse :: Bool -- ^Outcome of the request+ , commandInitializeResponse :: String -- ^The command requested + , messageInitializeResponse :: String -- ^Contains error message if success == false.+ , bodyInitializeResponse :: InitializeResponseBody -- ^The capabilities of this debug adapter+ } deriving (Show, Read, Eq)+++-- |+--+defaultInitializeResponse :: InitializeResponse+defaultInitializeResponse = InitializeResponse {+ seqInitializeResponse = 0+ , typeInitializeResponse = "response"+ , request_seqInitializeResponse = 0+ , successInitializeResponse = False+ , commandInitializeResponse = "initialize"+ , messageInitializeResponse = ""+ , bodyInitializeResponse = defaultInitializeResponseBody+ }+++-- |+-- Information about the capabilities of a debug adapter.+--+data InitializeResponseBody =+ InitializeResponseBody {+ supportsConfigurationDoneRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the 'configurationDone' request.+ , supportsFunctionBreakpointsInitializeResponseBody :: Bool -- ^The debug adapter supports functionBreakpoints.+ , supportsConditionalBreakpointsInitializeResponseBody :: Bool -- ^The debug adapter supports conditionalBreakpoints.+ , supportsHitConditionalBreakpointsInitializeResponseBody :: Bool -- ^The debug adapter supports breakpoints that break execution after a specified number of hits.+ , supportsEvaluateForHoversInitializeResponseBody :: Bool -- ^The debug adapter supports a (side effect free) evaluate request for data hovers.+ , exceptionBreakpointFiltersInitializeResponseBody :: [ExceptionBreakpointsFilter] -- ^Available filters for the setExceptionBreakpoints request.+ , supportsStepBackInitializeResponseBody :: Bool -- ^The debug adapter supports stepping back.+ , supportsSetVariableInitializeResponseBody :: Bool -- ^The debug adapter supports setting a variable to a value.+ , supportsRestartFrameInitializeResponseBody :: Bool -- ^The debug adapter supports restarting a frame.+ , supportsGotoTargetsRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the gotoTargetsRequest.+ , supportsStepInTargetsRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the stepInTargetsRequest. + , supportsCompletionsRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the completionsRequest.+ , supportsModulesRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the modules request.+ , additionalModuleColumnsInitializeResponseBody :: [ColumnDescriptor] -- ^The set of additional module information exposed by the debug adapter.+ , supportsLogPointsInitializeResponseBody :: Bool -- ^The debug adapter supports logpoints by interpreting the 'logMessage' attribute of the SourceBreakpoint.+ , supportsTerminateRequestInitializeResponseBody :: Bool -- ^The debug adapter supports the 'terminate' request.+ } deriving (Show, Read, Eq)++-- |+--+defaultInitializeResponseBody :: InitializeResponseBody+defaultInitializeResponseBody = InitializeResponseBody {+ supportsConfigurationDoneRequestInitializeResponseBody = False+ , supportsFunctionBreakpointsInitializeResponseBody = False+ , supportsConditionalBreakpointsInitializeResponseBody = False+ , supportsHitConditionalBreakpointsInitializeResponseBody = False+ , supportsEvaluateForHoversInitializeResponseBody = False+ , exceptionBreakpointFiltersInitializeResponseBody = []+ , supportsStepBackInitializeResponseBody = False+ , supportsSetVariableInitializeResponseBody = False+ , supportsRestartFrameInitializeResponseBody = False+ , supportsGotoTargetsRequestInitializeResponseBody = False+ , supportsStepInTargetsRequestInitializeResponseBody = False+ , supportsCompletionsRequestInitializeResponseBody = False+ , supportsModulesRequestInitializeResponseBody = False+ , additionalModuleColumnsInitializeResponseBody = []+ , supportsLogPointsInitializeResponseBody = False+ , supportsTerminateRequestInitializeResponseBody = False+ }+++----------------------------------------------------------------------------+-- Disconnect+----------------------------------------------------------------------------++-- |+-- Disconnect request; value of command field is 'disconnect'.+--+-- The 'disconnect' request is sent from the client to the debug adapter in order to stop debugging. +--+-- It asks the debug adapter to disconnect from the debuggee and to terminate the debug adapter.+--+-- If the debuggee has been started with the 'launch' request, the 'disconnect' request terminates the debuggee. +--+-- If the 'attach' request was used to connect to the debuggee, 'disconnect' does not terminate the debuggee. +--+-- This behavior can be controlled with the 'terminateDebuggee' argument (if supported by the debug adapter).+--+data DisconnectRequest =+ DisconnectRequest {+ seqDisconnectRequest :: Int -- ^Sequence number+ , typeDisconnectRequest :: String -- ^One of "request", "response", or "event"+ , commandDisconnectRequest :: String -- ^The command to execute+ , argumentsDisconnectRequest :: Maybe DisconnectRequestArguments -- ^Arguments for "disconnect" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'disconnect' request.+--+data DisconnectRequestArguments =+ DisconnectArguments {+ restartDisconnectRequestArguments :: Maybe Bool -- ^A value of true indicates that this 'disconnect' request is part of a restart sequence.+ } deriving (Show, Read, Eq)+++-- |+-- Response to 'disconnect' request. This is just an acknowledgement, so no body field is required.+--+data DisconnectResponse =+ DisconnectResponse {+ seqDisconnectResponse :: Int -- ^Sequence number+ , typeDisconnectResponse :: String -- ^One of "request", "response", or "event"+ , request_seqDisconnectResponse :: Int -- ^Sequence number of the corresponding request+ , successDisconnectResponse :: Bool -- ^Outcome of the request+ , commandDisconnectResponse :: String -- ^The command requested + , messageDisconnectResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultDisconnectResponse :: DisconnectResponse+defaultDisconnectResponse = DisconnectResponse {+ seqDisconnectResponse = 0+ , typeDisconnectResponse = "response"+ , request_seqDisconnectResponse = 0+ , successDisconnectResponse = False+ , commandDisconnectResponse = "disconnect"+ , messageDisconnectResponse = ""+ }++++----------------------------------------------------------------------------+-- PauseRequest+----------------------------------------------------------------------------++-- |+-- Pause request; value of command field is "pause".+--+-- The request suspenses the debuggee.+--+-- The debug adapter first sends the response and then a 'stopped' event (with reason 'pause') after the thread has been paused successfully.+--+data PauseRequest =+ PauseRequest {+ seqPauseRequest :: Int -- ^Sequence number+ , typePauseRequest :: String -- ^One of "request", "response", or "event"+ , commandPauseRequest :: String -- ^The command to execute+ , argumentsPauseRequest :: Maybe PauseRequestArguments -- ^Arguments for "pause" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for "pause" request.+--+data PauseRequestArguments =+ PauseArguments {+ threadIdPauseRequestArguments :: Int -- ^Pause execution for this thread. + } deriving (Show, Read, Eq)+++-- |+-- Response to "pause" request. This is just an acknowledgement, so no body field is required.+--+data PauseResponse =+ PauseResponse {+ seqPauseResponse :: Int -- ^Sequence number+ , typePauseResponse :: String -- ^One of "request", "response", or "event"+ , request_seqPauseResponse :: Int -- ^Sequence number of the corresponding request+ , successPauseResponse :: Bool -- ^Outcome of the request+ , commandPauseResponse :: String -- ^The command requested + , messagePauseResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultPauseResponse :: PauseResponse+defaultPauseResponse = PauseResponse {+ seqPauseResponse = 0+ , typePauseResponse = "response"+ , request_seqPauseResponse = 0+ , successPauseResponse = False+ , commandPauseResponse = "pause"+ , messagePauseResponse = ""+ }+++++----------------------------------------------------------------------------+-- Terminate+----------------------------------------------------------------------------++-- |+-- Terminate request; value of command field is 'terminate'.+--+-- The 'terminate' request is sent from the client to the debug adapter in order to give the debuggee a chance for terminating itself.+--+data TerminateRequest =+ TerminateRequest {+ seqTerminateRequest :: Int -- ^Sequence number+ , typeTerminateRequest :: String -- ^One of "request", "response", or "event"+ , commandTerminateRequest :: String -- ^The command to execute+ , argumentsTerminateRequest :: Maybe TerminateRequestArguments -- ^Arguments for "terminate" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'terminate' request. +--+data TerminateRequestArguments =+ TerminateArguments {+ restartTerminateRequestArguments :: Maybe Bool -- ^A value of true indicates that this 'terminate' request is part of a restart sequence.+ } deriving (Show, Read, Eq)+++-- |+-- Response to 'terminate' request. This is just an acknowledgement, so no body field is required.+--+data TerminateResponse =+ TerminateResponse {+ seqTerminateResponse :: Int -- ^Sequence number+ , typeTerminateResponse :: String -- ^One of "request", "response", or "event"+ , request_seqTerminateResponse :: Int -- ^Sequence number of the corresponding request+ , successTerminateResponse :: Bool -- ^Outcome of the request+ , commandTerminateResponse :: String -- ^The command requested + , messageTerminateResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultTerminateResponse :: TerminateResponse+defaultTerminateResponse = TerminateResponse {+ seqTerminateResponse = 0+ , typeTerminateResponse = "response"+ , request_seqTerminateResponse = 0+ , successTerminateResponse = False+ , commandTerminateResponse = "terminate"+ , messageTerminateResponse = ""+ }+++----------------------------------------------------------------------------+-- Launch+----------------------------------------------------------------------------++-- |+-- Launch request; value of command field is 'launch'.+--+-- The launch request is sent from the client to the debug adapter to start the debuggee with or without debugging (if 'noDebug' is true).+--+-- Since launching is debugger/runtime specific, the arguments for this request are not part of this specification.+--+data LaunchRequest =+ LaunchRequest {+ seqLaunchRequest :: Int -- ^Sequence number+ , typeLaunchRequest :: String -- ^One of "request", "response", or "event"+ , commandLaunchRequest :: String -- ^The command to execute+ , argumentsLaunchRequest :: LaunchRequestArguments -- ^Arguments for "launch" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'launch' request. Additional attributes are implementation specific.+--+data LaunchRequestArguments =+ LaunchRequestArguments {+ noDebugLaunchRequestArguments :: Maybe Bool -- ^If noDebug is true the launch request should launch the program without enabling debugging.+ , nameLaunchRequestArguments :: String -- ^Phoityne specific argument. Must be "haskell-debug-adapter".+ , typeLaunchRequestArguments :: String -- ^Phoityne specific argument. Must be "ghc".+ , requestLaunchRequestArguments :: String -- ^Phoityne specific argument. Must be "launch".+ , startupLaunchRequestArguments :: String -- ^Phoityne specific argument. The path to debug start file.+ , workspaceLaunchRequestArguments :: String -- ^Phoityne specific argument. The path to debugee workspace.+ , logFileLaunchRequestArguments :: String -- ^Phoityne specific argument. The path to the log file.+ , logLevelLaunchRequestArguments :: String -- ^Phoityne specific argument. The Logging Prioryt+ , ghciPromptLaunchRequestArguments :: String -- ^Phoityne specific argument. The ghci prompt used by hda.+ , ghciCmdLaunchRequestArguments :: String -- ^Phoityne specific argument. The command to start debugging.+ , stopOnEntryLaunchRequestArguments :: Bool -- ^Phoityne specific argument. Stop at the debugged function entry point.+ , mainArgsLaunchRequestArguments :: Maybe String -- ^Phoityne specific argument. required. Arguments of main function.+ , ghciEnvLaunchRequestArguments :: M.Map String String -- ^Phoityne specific argument. required. Additional Environments while debugging.+ , ghciInitialPromptLaunchRequestArguments :: Maybe String -- ^Phoityne specific argument. The ghci initial prompt.+ , startupFuncLaunchRequestArguments :: Maybe String -- ^Phoityne specific argument. The debug entry function.+ , startupArgsLaunchRequestArguments :: Maybe String -- ^Phoityne specific argument. Arguments of the debug entry function.+ } deriving (Show, Read, Eq)+++-- |+-- Response to 'launch' request. This is just an acknowledgement, so no body field is required. +--+data LaunchResponse =+ LaunchResponse {+ seqLaunchResponse :: Int -- ^Sequence number+ , typeLaunchResponse :: String -- ^One of "request", "response", or "event"+ , request_seqLaunchResponse :: Int -- ^Sequence number of the corresponding request+ , successLaunchResponse :: Bool -- ^Outcome of the request+ , commandLaunchResponse :: String -- ^The command requested + , messageLaunchResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultLaunchResponse :: LaunchResponse+defaultLaunchResponse = LaunchResponse {+ seqLaunchResponse = 0+ , typeLaunchResponse = "response"+ , request_seqLaunchResponse = 0+ , successLaunchResponse = False+ , commandLaunchResponse = "launch"+ , messageLaunchResponse = ""+ }+++----------------------------------------------------------------------------+-- SetBreakpoints+----------------------------------------------------------------------------++-- |+-- Properties of a breakpoint passed to the setBreakpoints request.+--+data SourceBreakpoint =+ SourceBreakpoint {+ lineSourceBreakpoint :: Int -- ^The source line of the breakpoint.+ , columnSourceBreakpoint :: Maybe Int -- ^An optional source column of the breakpoint. + , conditionSourceBreakpoint :: Maybe String -- ^An optional expression for conditional breakpoints.+ , hitConditionSourceBreakpoint :: Maybe String -- ^An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed.+ , logMessageSourceBreakpoint :: Maybe String -- ^If this attribute exists and is non-empty, the backend must not 'break' (stop) but log the message instead. Expressions within {} are interpolated.+ } deriving (Show, Read, Eq)++-- |+-- SetBreakpoints request; value of command field is "setBreakpoints".+--+-- Sets multiple breakpoints for a single source and clears all previous breakpoints in that source.+--+-- To clear all breakpoint for a source, specify an empty array.+--+-- When a breakpoint is hit, a StoppedEvent (event type 'breakpoint') is generated.+--+data SetBreakpointsRequest =+ SetBreakpointsRequest {+ seqSetBreakpointsRequest :: Int -- ^Sequence number+ , typeSetBreakpointsRequest :: String -- ^One of "request", "response", or "event"+ , commandSetBreakpointsRequest :: String -- ^The command to execute+ , argumentsSetBreakpointsRequest :: SetBreakpointsRequestArguments -- ^Arguments for "setBreakpoints" request.+ } deriving (Show, Read, Eq)++++-- |+-- Arguments for 'setBreakpoints' request.+--+data SetBreakpointsRequestArguments =+ SetBreakpointsRequestArguments {+ sourceSetBreakpointsRequestArguments :: Source -- ^The source location of the breakpoints; either source.path or source.reference must be specified. + , breakpointsSetBreakpointsRequestArguments :: [SourceBreakpoint] -- ^The code locations of the breakpoints.+ } deriving (Show, Read, Eq)++++-- |+-- Response to "setBreakpoints" request.+--+-- Returned is information about each breakpoint created by this request.+--+-- This includes the actual code location and whether the breakpoint could be verified.+--+-- The breakpoints returned are in the same order as the elements of the 'breakpoints'+--+-- (or the deprecated 'lines') in the SetBreakpointsRequestArguments.+--+data SetBreakpointsResponse =+ SetBreakpointsResponse {+ seqSetBreakpointsResponse :: Int -- ^Sequence number+ , typeSetBreakpointsResponse :: String -- ^One of "request", "response", or "event"+ , request_seqSetBreakpointsResponse :: Int -- ^Sequence number of the corresponding request+ , successSetBreakpointsResponse :: Bool -- ^Outcome of the request+ , commandSetBreakpointsResponse :: String -- ^The command requested + , messageSetBreakpointsResponse :: String -- ^Contains error message if success == false.+ , bodySetBreakpointsResponse :: SetBreakpointsResponseBody -- ^The body of SetBreakpointsResponse.+ } deriving (Show, Read, Eq)+++-- |+--+defaultSetBreakpointsResponse :: SetBreakpointsResponse+defaultSetBreakpointsResponse = SetBreakpointsResponse {+ seqSetBreakpointsResponse = 0+ , typeSetBreakpointsResponse = "response"+ , request_seqSetBreakpointsResponse = 0+ , successSetBreakpointsResponse = False+ , commandSetBreakpointsResponse = "setBreakpoints"+ , messageSetBreakpointsResponse = ""+ , bodySetBreakpointsResponse = defaultSetBreakpointsResponseBody+ }++-- |+-- Response to "setBreakpoints" request.+-- +-- Returned is information about each breakpoint created by this request.+-- +-- This includes the actual code location and whether the breakpoint could be verified.+-- +-- The breakpoints returned are in the same order as the elements of the 'breakpoints'+-- +-- (or the deprecated 'lines') in the SetBreakpointsRequestArguments.+--+data SetBreakpointsResponseBody =+ SetBreakpointsResponseBody {+ breakpointsSetBreakpointsResponseBody :: [Breakpoint] -- ^Information about the breakpoints. The array elements are in the same order as the elements of the 'breakpoints' (or the deprecated 'lines') in the SetBreakpointsRequestArguments.+ } deriving (Show, Read, Eq)+++-- |+--+defaultSetBreakpointsResponseBody :: SetBreakpointsResponseBody+defaultSetBreakpointsResponseBody = SetBreakpointsResponseBody {+ breakpointsSetBreakpointsResponseBody = []+ }+++----------------------------------------------------------------------------+-- SetFunctionBreakpoints+----------------------------------------------------------------------------++-- |+-- Properties of a breakpoint passed to the setFunctionBreakpoints request.+--+data FunctionBreakpoint =+ FunctionBreakpoint {+ nameFunctionBreakpoint :: String -- The name of the function. + , conditionFunctionBreakpoint :: Maybe String -- An optional expression for conditional breakpoints.+ , hitConditionFunctionBreakpoint :: Maybe String -- An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed.+ } deriving (Show, Read, Eq)+++-- |+-- SetFunctionBreakpoints request; value of command field is "setFunctionBreakpoints".+-- +-- Sets multiple function breakpoints and clears all previous function breakpoints.+-- +-- To clear all function breakpoint, specify an empty array.+-- +-- When a function breakpoint is hit, a StoppedEvent (event type 'function breakpoint') is generated.+--+data SetFunctionBreakpointsRequest =+ SetFunctionBreakpointsRequest {+ seqSetFunctionBreakpointsRequest :: Int -- ^Sequence number+ , typeSetFunctionBreakpointsRequest :: String -- ^One of "request", "response", or "event"+ , commandSetFunctionBreakpointsRequest :: String -- ^The command to execute+ , argumentsSetFunctionBreakpointsRequest :: SetFunctionBreakpointsRequestArguments -- ^Arguments for "setFunctionBreakpoints" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'setFunctionBreakpoints' request. +--+data SetFunctionBreakpointsRequestArguments =+ SetFunctionBreakpointsRequestArguments {+ breakpointsSetFunctionBreakpointsRequestArguments :: [FunctionBreakpoint] -- ^The function names of the breakpoints.+ } deriving (Show, Read, Eq)+++-- |+-- Response to "setFunctionBreakpoints" request.+--+data SetFunctionBreakpointsResponse =+ SetFunctionBreakpointsResponse {+ seqSetFunctionBreakpointsResponse :: Int -- ^Sequence number+ , typeSetFunctionBreakpointsResponse :: String -- ^One of "request", "response", or "event"+ , request_seqSetFunctionBreakpointsResponse :: Int -- ^Sequence number of the corresponding request+ , successSetFunctionBreakpointsResponse :: Bool -- ^Outcome of the request+ , commandSetFunctionBreakpointsResponse :: String -- ^The command requested + , messageSetFunctionBreakpointsResponse :: String -- ^Contains error message if success == false.+ , bodySetFunctionBreakpointsResponse :: SetFunctionBreakpointsResponseBody -- ^The body of the SetFunctionBreakpointsResponse+ } deriving (Show, Read, Eq)+++-- |+--+defaultSetFunctionBreakpointsResponse :: SetFunctionBreakpointsResponse+defaultSetFunctionBreakpointsResponse = SetFunctionBreakpointsResponse {+ seqSetFunctionBreakpointsResponse = 0+ , typeSetFunctionBreakpointsResponse = "response"+ , request_seqSetFunctionBreakpointsResponse = 0+ , successSetFunctionBreakpointsResponse = False+ , commandSetFunctionBreakpointsResponse = "setFunctionBreakpoints"+ , messageSetFunctionBreakpointsResponse = ""+ , bodySetFunctionBreakpointsResponse = defaultSetFunctionBreakpointsResponseBody+ }+++-- |+-- Response to 'setFunctionBreakpoints' request.+-- +-- Returned is information about each breakpoint created by this request.+--+data SetFunctionBreakpointsResponseBody =+ SetFunctionBreakpointsResponseBody {+ breakpointsSetFunctionBreakpointsResponseBody :: [Breakpoint] -- ^Information about the breakpoints. The array elements correspond to the elements of the 'breakpoints' array.+ } deriving (Show, Read, Eq)+++-- |+--+defaultSetFunctionBreakpointsResponseBody :: SetFunctionBreakpointsResponseBody+defaultSetFunctionBreakpointsResponseBody = SetFunctionBreakpointsResponseBody {+ breakpointsSetFunctionBreakpointsResponseBody = []+ }+++----------------------------------------------------------------------------+-- SetExceptionBreakpoints+----------------------------------------------------------------------------++-- |+-- SetExceptionBreakpoints request; value of command field is 'setExceptionBreakpoints'.+--+-- The request configures the debuggers response to thrown exceptions. If an exception is configured to break,+--+-- a StoppedEvent is fired (event type 'exception').+--+data SetExceptionBreakpointsRequest =+ SetExceptionBreakpointsRequest {+ seqSetExceptionBreakpointsRequest :: Int -- ^Sequence number+ , typeSetExceptionBreakpointsRequest :: String -- ^One of "request", "response", or "event"+ , commandSetExceptionBreakpointsRequest :: String -- ^The command to execute+ , argumentsSetExceptionBreakpointsRequest :: SetExceptionBreakpointsRequestArguments -- ^Arguments for "setExceptionBreakpoints" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'setExceptionBreakpoints' request.+--+data SetExceptionBreakpointsRequestArguments =+ SetExceptionBreakpointsRequestArguments {+ filtersSetExceptionBreakpointsRequestArguments :: [String] -- ^IDs of checked exception options. The set of IDs is returned via the 'exceptionBreakpointFilters' capability.+ } deriving (Show, Read, Eq)++++-- |+-- Response to 'setExceptionBreakpoints' request. This is just an acknowledgement, so no body field is required.+--+data SetExceptionBreakpointsResponse =+ SetExceptionBreakpointsResponse {+ seqSetExceptionBreakpointsResponse :: Int -- ^Sequence number+ , typeSetExceptionBreakpointsResponse :: String -- ^One of "request", "response", or "event"+ , request_seqSetExceptionBreakpointsResponse :: Int -- ^Sequence number of the corresponding request+ , successSetExceptionBreakpointsResponse :: Bool -- ^Outcome of the request+ , commandSetExceptionBreakpointsResponse :: String -- ^The command requested + , messageSetExceptionBreakpointsResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultSetExceptionBreakpointsResponse :: SetExceptionBreakpointsResponse+defaultSetExceptionBreakpointsResponse = SetExceptionBreakpointsResponse {+ seqSetExceptionBreakpointsResponse = 0+ , typeSetExceptionBreakpointsResponse = "response"+ , request_seqSetExceptionBreakpointsResponse = 0+ , successSetExceptionBreakpointsResponse = False+ , commandSetExceptionBreakpointsResponse = "setExceptionBreakpoints"+ , messageSetExceptionBreakpointsResponse = ""+ }+++----------------------------------------------------------------------------+-- ConfigurationDone+----------------------------------------------------------------------------++-- |+-- ConfigurationDone request; value of command field is 'configurationDone'.+-- +-- The client of the debug protocol must send this request at the end of the sequence of configuration requests+-- +-- (which was started by the InitializedEvent).+--+data ConfigurationDoneRequest =+ ConfigurationDoneRequest {+ seqConfigurationDoneRequest :: Int -- ^Sequence number+ , typeConfigurationDoneRequest :: String -- ^One of "request", "response", or "event"+ , commandConfigurationDoneRequest :: String -- ^The command to execute+ } deriving (Show, Read, Eq)+++-- |+-- Response to 'configurationDone' request. This is just an acknowledgement, so no body field is required.+--+data ConfigurationDoneResponse =+ ConfigurationDoneResponse {+ seqConfigurationDoneResponse :: Int -- ^Sequence number+ , typeConfigurationDoneResponse :: String -- ^One of "request", "response", or "event"+ , request_seqConfigurationDoneResponse :: Int -- ^Sequence number of the corresponding request+ , successConfigurationDoneResponse :: Bool -- ^Outcome of the request+ , commandConfigurationDoneResponse :: String -- ^The command requested + , messageConfigurationDoneResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultConfigurationDoneResponse :: ConfigurationDoneResponse+defaultConfigurationDoneResponse = ConfigurationDoneResponse {+ seqConfigurationDoneResponse = 0+ , typeConfigurationDoneResponse = "response"+ , request_seqConfigurationDoneResponse = 0+ , successConfigurationDoneResponse = False+ , commandConfigurationDoneResponse = "configurationDone"+ , messageConfigurationDoneResponse = ""+ }+++----------------------------------------------------------------------------+-- Thread+----------------------------------------------------------------------------++-- |+-- Thread request; value of command field is "threads".+--+-- The request retrieves a list of all threads.+--+data ThreadsRequest =+ ThreadsRequest {+ seqThreadsRequest :: Int -- ^Sequence number+ , typeThreadsRequest :: String -- ^One of "request", "response", or "event"+ , commandThreadsRequest :: String -- ^The command to execute+ } deriving (Show, Read, Eq)+++-- |+-- Response to "threads" request. +--+data ThreadsResponse =+ ThreadsResponse {+ seqThreadsResponse :: Int -- ^Sequence number+ , typeThreadsResponse :: String -- ^One of "request", "response", or "event"+ , request_seqThreadsResponse :: Int -- ^Sequence number of the corresponding request+ , successThreadsResponse :: Bool -- ^Outcome of the request+ , commandThreadsResponse :: String -- ^The command requested + , messageThreadsResponse :: String -- ^Contains error message if success == false.+ , bodyThreadsResponse :: ThreadsResponseBody -- ^The body of ThreadsResponse+ } deriving (Show, Read, Eq)+++-- |+--+defaultThreadsResponse :: ThreadsResponse+defaultThreadsResponse = ThreadsResponse {+ seqThreadsResponse = 0+ , typeThreadsResponse = "response"+ , request_seqThreadsResponse = 0+ , successThreadsResponse = False+ , commandThreadsResponse = "threads"+ , messageThreadsResponse = ""+ , bodyThreadsResponse = defaultThreadsResponseBody+ }+++-- |+-- Response to "threads" request.+--+data ThreadsResponseBody =+ ThreadsResponseBody {+ threadsThreadsResponseBody :: [Thread] -- ^All threads.+ } deriving (Show, Read, Eq)+++-- |+--+defaultThreadsResponseBody :: ThreadsResponseBody+defaultThreadsResponseBody = ThreadsResponseBody [defaultThread]+++-- |+-- A Thread is a name/value pair.+--+-- If the value is structured (has children), a handle is provided to retrieve the children with the ThreadsRequest.+--+data Thread =+ Thread {+ idThread :: Int -- ^Unique identifier for the thread. + , nameThread :: String -- ^A name of the thread. + } deriving (Show, Read, Eq)+++-- |+--+defaultThread :: Thread+defaultThread = Thread _THREAD_ID "ghci main thread"+++----------------------------------------------------------------------------+-- StackTrace+----------------------------------------------------------------------------++-- |+-- StackTrace request; value of command field is "stackTrace".+--+-- The request returns a stacktrace from the current execution state.+--+data StackTraceRequest =+ StackTraceRequest {+ seqStackTraceRequest :: Int -- ^Sequence number+ , typeStackTraceRequest :: String -- ^One of "request", "response", or "event"+ , commandStackTraceRequest :: String -- ^The command to execute+ , argumentsStackTraceRequest :: StackTraceRequestArguments -- ^Arguments for "stackTrace" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'stackTrace' request.+--+data StackTraceRequestArguments =+ StackTraceRequestArguments {+ threadIdStackTraceRequestArguments :: Int -- ^Retrieve the stacktrace for this thread.+ , startFrameStackTraceRequestArguments :: Maybe Int -- ^The index of the first frame to return; if omitted frames start at 0.+ , levelsStackTraceRequestArguments :: Int -- ^The maximum number of frames to return. If levels is not specified or 0, all frames are returned.+ } deriving (Show, Read, Eq)+++-- |+-- A Stackframe contains the source location.+--+data StackFrame =+ StackFrame {+ idStackFrame :: Int -- ^An identifier for the stack frame. It must be unique across all threads. This id can be used to retrieve the scopes of the frame with the 'scopesRequest' or to restart the execution of a stackframe.+ , nameStackFrame :: String -- ^The name of the stack frame, typically a method name.+ , sourceStackFrame :: Source -- ^The optional source of the frame.+ , lineStackFrame :: Int -- ^The line within the file of the frame. If source is null or doesn't exist, line is 0 and must be ignored.+ , columnStackFrame :: Int -- ^The column within the line. If source is null or doesn't exist, column is 0 and must be ignored. + , endLineStackFrame :: Int -- ^An optional end line of the range covered by the stack frame.+ , endColumnStackFrame :: Int -- ^An optional end column of the range covered by the stack frame.+ } deriving (Show, Read, Eq)+++-- |+--+defaultStackFrame :: StackFrame+defaultStackFrame = StackFrame {+ idStackFrame = 0+ , nameStackFrame = ""+ , sourceStackFrame = defaultSource+ , lineStackFrame = 0+ , columnStackFrame = 0+ , endLineStackFrame = 0+ , endColumnStackFrame = 0+}++-- |+-- Response to "stackTrace" request.+--+data StackTraceResponse =+ StackTraceResponse {+ seqStackTraceResponse :: Int -- ^Sequence number+ , typeStackTraceResponse :: String -- ^One of "request", "response", or "event"+ , request_seqStackTraceResponse :: Int -- ^Sequence number of the corresponding request+ , successStackTraceResponse :: Bool -- ^Outcome of the request+ , commandStackTraceResponse :: String -- ^The command requested + , messageStackTraceResponse :: String -- ^Contains error message if success == false.+ , bodyStackTraceResponse :: StackTraceResponseBody -- ^The body of StackTraceResponse+ } deriving (Show, Read, Eq)++defaultStackTraceResponse :: StackTraceResponse+defaultStackTraceResponse = StackTraceResponse {+ seqStackTraceResponse = 0+ , typeStackTraceResponse = "response"+ , request_seqStackTraceResponse = 0+ , successStackTraceResponse = False+ , commandStackTraceResponse = "stackTrace"+ , messageStackTraceResponse = ""+ , bodyStackTraceResponse = defaultStackTraceResponseBody+ }+++-- |+-- Response to 'stackTrace' request.+--+data StackTraceResponseBody =+ StackTraceResponseBody {+ stackFramesStackTraceResponseBody :: [StackFrame] -- ^The frames of the stackframe. If the array has length zero, there are no stackframes available. This means that there is no location information available.+ , totalFramesStackTraceResponseBody :: Int -- ^The total number of frames available. + } deriving (Show, Read, Eq)++-- |+--+defaultStackTraceResponseBody :: StackTraceResponseBody+defaultStackTraceResponseBody = StackTraceResponseBody {+ stackFramesStackTraceResponseBody = []+ , totalFramesStackTraceResponseBody = 0+ }++----------------------------------------------------------------------------+-- Scopes+----------------------------------------------------------------------------+++-- |+-- Scopes request; value of command field is "scopes".+--+-- The request returns the variable scopes for a given stackframe ID.+--+data ScopesRequest =+ ScopesRequest {+ seqScopesRequest :: Int -- ^Sequence number+ , typeScopesRequest :: String -- ^One of "request", "response", or "event"+ , commandScopesRequest :: String -- ^The command to execute+ , argumentsScopesRequest :: ScopesRequestArguments -- ^Arguments for "scopes" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for "scopes" request.+--+data ScopesRequestArguments =+ ScopesRequestArguments {+ frameIdScopesRequestArguments :: Int -- ^Retrieve the scopes for this stackframe.+ } deriving (Show, Read, Eq)+++-- |+-- Response to "scopes" request.+--+data ScopesResponse =+ ScopesResponse {+ seqScopesResponse :: Int -- ^Sequence number+ , typeScopesResponse :: String -- ^One of "request", "response", or "event"+ , request_seqScopesResponse :: Int -- ^Sequence number of the corresponding request+ , successScopesResponse :: Bool -- ^Outcome of the request+ , commandScopesResponse :: String -- ^The command requested + , messageScopesResponse :: String -- ^Contains error message if success == false.+ , bodyScopesResponse :: ScopesResponseBody -- ^The body of ScopesResponse.+ } deriving (Show, Read, Eq)++-- |+--+defaultScopesResponse :: ScopesResponse+defaultScopesResponse = ScopesResponse {+ seqScopesResponse = 0+ , typeScopesResponse = "response"+ , request_seqScopesResponse = 0+ , successScopesResponse = False+ , commandScopesResponse = "scopes"+ , messageScopesResponse = ""+ , bodyScopesResponse = defaultScopesResponseBody+ }++-- |+-- Response to 'scopes' request.+--+data ScopesResponseBody =+ ScopesResponseBody {+ scopesScopesResponseBody :: [Scope] -- ^The scopes of the stackframe. If the array has length zero, there are no scopes available.+ } deriving (Show, Read, Eq)+++-- |+--+defaultScopesResponseBody :: ScopesResponseBody+defaultScopesResponseBody = ScopesResponseBody {+ scopesScopesResponseBody = []+ }++-- |+-- A Scope is a named container for variables. Optionally a scope can map to a source or a range within a source. +--+data Scope =+ Scope {+ nameScope :: String -- ^Name of the scope such as 'Arguments', 'Locals'. + , variablesReferenceScope :: Int -- ^The variables of this scope can be retrieved by passing the value of variablesReference to the VariablesRequest.+ , namedVariablesScope :: Maybe Int -- ^The number of named variables in this scope. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , indexedVariablesScope :: Maybe Int -- ^The number of indexed variables in this scope. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , expensiveScope :: Bool -- ^If true, the number of variables in this scope is large or expensive to retrieve.+ } deriving (Show, Read, Eq)++-- |+--+defaultScope :: Scope+defaultScope = Scope {+ nameScope = ""+ , variablesReferenceScope = 0+ , namedVariablesScope = Nothing+ , indexedVariablesScope = Nothing+ , expensiveScope = False+ }+++----------------------------------------------------------------------------+-- Variables+----------------------------------------------------------------------------++-- |+-- Variables request; value of command field is "variables".+--+-- Retrieves all children for the given variable reference.+--+data VariablesRequest =+ VariablesRequest {+ seqVariablesRequest :: Int -- ^Sequence number+ , typeVariablesRequest :: String -- ^One of "request", "response", or "event"+ , commandVariablesRequest :: String -- ^The command to execute+ , argumentsVariablesRequest :: VariablesRequestArguments -- ^Arguments for "variables" request.+ } deriving (Show, Read, Eq)+++-- |+-- Response to "variables" request. +--+data VariablesResponse =+ VariablesResponse {+ seqVariablesResponse :: Int -- ^Sequence number+ , typeVariablesResponse :: String -- ^One of "request", "response", or "event"+ , request_seqVariablesResponse :: Int -- ^Sequence number of the corresponding request+ , successVariablesResponse :: Bool -- ^Outcome of the request+ , commandVariablesResponse :: String -- ^The command requested + , messageVariablesResponse :: String -- ^Contains error message if success == false.+ , bodyVariablesResponse :: VariablesResponseBody -- ^The body of VariablesResponse+ } deriving (Show, Read, Eq)+++-- |+--+defaultVariablesResponse :: VariablesResponse+defaultVariablesResponse = VariablesResponse {+ seqVariablesResponse = 0+ , typeVariablesResponse = "response"+ , request_seqVariablesResponse = 0+ , successVariablesResponse = False+ , commandVariablesResponse = "variables"+ , messageVariablesResponse = ""+ , bodyVariablesResponse = defaultVariablesResponseBody+ }+++-- |+-- Arguments for 'variables' request. +--+data VariablesRequestArguments =+ VariablesRequestArguments {+ variablesReferenceVariablesRequestArguments :: Int -- ^The Variable reference.+ } deriving (Show, Read, Eq)+++-- |+-- Response to "variables" request.+--+data VariablesResponseBody =+ VariablesResponseBody {+ variablesVariablesResponseBody :: [Variable] -- ^All (or a range) of variables for the given variable reference.+ } deriving (Show, Read, Eq)+++-- |+--+defaultVariablesResponseBody :: VariablesResponseBody+defaultVariablesResponseBody = VariablesResponseBody []+++-- |+-- A Variable is a name/value pair.+--+-- If the value is structured (has children), a handle is provided to retrieve the children with the VariablesRequest.+--+data Variable =+ Variable {+ nameVariable :: String -- ^The variable's name.+ , valueVariable :: String -- ^The variable's value. This can be a multi-line text, e.g. for a function the body of a function.+ , typeVariable :: String -- ^The type of the variable's value. Typically shown in the UI when hovering over the value.+ , presentationHintVariable :: Maybe VariablePresentationHint -- ^Properties of a variable that can be used to determine how to render the variable in the UI.+ , evaluateNameVariable :: Maybe String -- ^Optional evaluatable name of this variable which can be passed to the 'EvaluateRequest' to fetch the variable's value.+ , variablesReferenceVariable :: Int -- ^If variablesReference is > 0, the variable is structured and its children can be retrieved by passing variablesReference to the VariablesRequest.+ , namedVariablesVariable :: Maybe Int -- ^The number of named child variables.+ , indexedVariablesVariable :: Maybe Int -- ^The number of indexed child variables. The client can use this optional information to present the children in a paged UI and fetch them in chunks.+ } deriving (Show, Read, Eq)++-- |+-- +defaultVariable :: Variable+defaultVariable = Variable {+ nameVariable = ""+ , valueVariable = ""+ , typeVariable = ""+ , presentationHintVariable = Nothing+ , evaluateNameVariable = Nothing+ , variablesReferenceVariable = 0+ , namedVariablesVariable = Nothing+ , indexedVariablesVariable = Nothing+ }++-- |+-- Optional properties of a variable that can be used to determine how to render the variable in the UI.+--+data VariablePresentationHint =+ VariablePresentationHint {+ {-|+ The kind of variable. Before introducing additional values, try to use the listed values.+ + Values:++ 'property': Indicates that the object is a property.++ 'method': Indicates that the object is a method.+ + 'class': Indicates that the object is a class.++ 'data': Indicates that the object is data.++ 'event': Indicates that the object is an event.++ 'baseClass': Indicates that the object is a base class.++ 'innerClass': Indicates that the object is an inner class.++ 'interface': Indicates that the object is an interface.++ 'mostDerivedClass': Indicates that the object is the most derived class.++ 'virtual': Indicates that the object is virtual, that means it is a synthetic object introduced by the adapter for rendering purposes, e.g. an index range for large arrays.+ -}+ kindVariablePresentationHint :: String+ {-|+ Set of attributes represented as an array of strings. Before introducing additional values, try to use the listed values.+ Values: ++ 'static': Indicates that the object is static.++ 'constant': Indicates that the object is a constant.++ 'readOnly': Indicates that the object is read only.++ 'rawString': Indicates that the object is a raw string.++ 'hasObjectId': Indicates that the object can have an Object ID created for it.++ 'canHaveObjectId': Indicates that the object has an Object ID associated with it.++ 'hasSideEffects': Indicates that the evaluation had side effects.+ -}+ , attributesVariablePresentationHint :: [String]+ {-|+ Visibility of variable. Before introducing additional values, try to use the listed values.++ Values: 'public', 'private', 'protected', 'internal', 'final', etc.+ -}+ , visibilityVariablePresentationHint :: String+ } deriving (Show, Read, Eq)++++----------------------------------------------------------------------------+-- Continue+----------------------------------------------------------------------------++-- |+-- Continue request; value of command field is "continue".+--+-- The request starts the debuggee to run again.+--+data ContinueRequest =+ ContinueRequest {+ seqContinueRequest :: Int -- ^Sequence number+ , typeContinueRequest :: String -- ^One of "request", "response", or "event"+ , commandContinueRequest :: String -- ^The command to execute+ , argumentsContinueRequest :: ContinueRequestArguments -- ^Arguments for "continue" request.+ } deriving (Show, Read, Eq)++++-- |+-- Arguments for 'continue' request.+--+data ContinueRequestArguments =+ ContinueRequestArguments {+ threadIdContinueRequestArguments :: Int -- ^Continue execution for the specified thread (if possible). If the backend cannot continue on a single thread but will continue on all threads, it should set the allThreadsContinued attribute in the response to true.+ , exprContinueRequestArguments :: Maybe String -- ^ADD: haskell-dap+ } deriving (Show, Read, Eq)+++-- |+--+defaultContinueRequestArguments :: ContinueRequestArguments+defaultContinueRequestArguments = ContinueRequestArguments {+ threadIdContinueRequestArguments = _THREAD_ID+ , exprContinueRequestArguments = Nothing+ }+++-- |+-- Response to "continue" request. This is just an acknowledgement, so no body field is required. +--+data ContinueResponse =+ ContinueResponse {+ seqContinueResponse :: Int -- ^Sequence number+ , typeContinueResponse :: String -- ^One of "request", "response", or "event"+ , request_seqContinueResponse :: Int -- ^Sequence number of the corresponding request+ , successContinueResponse :: Bool -- ^Outcome of the request+ , commandContinueResponse :: String -- ^The command requested + , messageContinueResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultContinueResponse :: ContinueResponse+defaultContinueResponse = ContinueResponse {+ seqContinueResponse = 0+ , typeContinueResponse = "response"+ , request_seqContinueResponse = 0+ , successContinueResponse = False+ , commandContinueResponse = "continue"+ , messageContinueResponse = ""+ }+++----------------------------------------------------------------------------+-- Next+----------------------------------------------------------------------------++-- |+-- Next request; value of command field is "next".+--+-- The request starts the debuggee to run again for one step.+--+-- penDebug will respond with a StoppedEvent (event type 'step') after running the step.+--+data NextRequest =+ NextRequest {+ seqNextRequest :: Int -- ^Sequence number+ , typeNextRequest :: String -- ^One of "request", "response", or "event"+ , commandNextRequest :: String -- ^The command to execute+ , argumentsNextRequest :: NextRequestArguments -- ^Arguments for "disconnect" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'next' request.+--+data NextRequestArguments =+ NextRequestArguments {+ threadIdNextRequestArguments :: Int -- ^Execute 'next' for this thread. + } deriving (Show, Read, Eq)+++-- |+-- Response to "next" request. This is just an acknowledgement, so no body field is required.+--+data NextResponse =+ NextResponse {+ seqNextResponse :: Int -- ^Sequence number+ , typeNextResponse :: String -- ^One of "request", "response", or "event"+ , request_seqNextResponse :: Int -- ^Sequence number of the corresponding request+ , successNextResponse :: Bool -- ^Outcome of the request+ , commandNextResponse :: String -- ^The command requested + , messageNextResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultNextResponse :: NextResponse+defaultNextResponse = NextResponse {+ seqNextResponse = 0+ , typeNextResponse = "response"+ , request_seqNextResponse = 0+ , successNextResponse = False+ , commandNextResponse = "next"+ , messageNextResponse = ""+ }+++----------------------------------------------------------------------------+-- StepIn+----------------------------------------------------------------------------++-- |+-- StepIn request; value of command field is "stepIn".+--+-- The request starts the debuggee to run again for one step.+--+-- The debug adapter will respond with a StoppedEvent (event type 'step') after running the step.+--+data StepInRequest =+ StepInRequest {+ seqStepInRequest :: Int -- ^Sequence number+ , typeStepInRequest :: String -- ^One of "request", "response", or "event"+ , commandStepInRequest :: String -- ^The command to execute+ , argumentsStepInRequest :: StepInRequestArguments -- ^Arguments for "stepIn" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'stepIn' request. +--+data StepInRequestArguments =+ StepInRequestArguments {+ threadIdStepInRequestArguments :: Int -- ^Execute 'stepIn' for this thread.+ } deriving (Show, Read, Eq)+++-- |+-- Response to "stepIn" request. This is just an acknowledgement, so no body field is required.+--+data StepInResponse =+ StepInResponse {+ seqStepInResponse :: Int -- ^Sequence number+ , typeStepInResponse :: String -- ^One of "request", "response", or "event"+ , request_seqStepInResponse :: Int -- ^Sequence number of the corresponding request+ , successStepInResponse :: Bool -- ^Outcome of the request+ , commandStepInResponse :: String -- ^The command requested + , messageStepInResponse :: String -- ^Contains error message if success == false.+ } deriving (Show, Read, Eq)+++-- |+--+defaultStepInResponse :: StepInResponse+defaultStepInResponse = StepInResponse {+ seqStepInResponse = 0+ , typeStepInResponse = "response"+ , request_seqStepInResponse = 0+ , successStepInResponse = False+ , commandStepInResponse = "stepIn"+ , messageStepInResponse = ""+ }+++----------------------------------------------------------------------------+-- Evaluate+----------------------------------------------------------------------------++-- |+-- Evaluate request; value of command field is "evaluate".+--+-- Evaluates the given expression in the context of the top most stack frame.+--+-- The expression has access to any variables and arguments that are in scope.+--+data EvaluateRequest =+ EvaluateRequest {+ seqEvaluateRequest :: Int -- ^Sequence number+ , typeEvaluateRequest :: String -- ^One of "request", "response", or "event"+ , commandEvaluateRequest :: String -- ^The command to execute+ , argumentsEvaluateRequest :: EvaluateRequestArguments -- ^Arguments for "evaluate" request.+ } deriving (Show, Read, Eq)+++-- |+--+defaultEvaluateResponse :: EvaluateResponse+defaultEvaluateResponse = EvaluateResponse {+ seqEvaluateResponse = 0+ , typeEvaluateResponse = "response"+ , request_seqEvaluateResponse = 0+ , successEvaluateResponse = False+ , commandEvaluateResponse = "evaluate"+ , messageEvaluateResponse = ""+ , bodyEvaluateResponse = defaultEvaluateResponseBody+ }+++-- |+-- rguments for 'evaluate' request.+--+data EvaluateRequestArguments =+ EvaluateRequestArguments {+ expressionEvaluateRequestArguments :: String -- ^The expression to evaluate. + , frameIdEvaluateRequestArguments :: Maybe Int -- ^Evaluate the expression in the scope of this stack frame. If not specified, the expression is evaluated in the global scope. ++ {-|+ The context in which the evaluate request is run.+ Values:+ 'watch': evaluate is run in a watch.++ 'repl': evaluate is run from REPL console.++ 'hover': evaluate is run from a data hover.+ + etc. + -}+ , contextEvaluateRequestArguments :: Maybe String+ } deriving (Show, Read, Eq)+++-- |+-- Response to "evaluate" request.+--+data EvaluateResponse =+ EvaluateResponse {+ seqEvaluateResponse :: Int -- ^Sequence number+ , typeEvaluateResponse :: String -- ^One of "request", "response", or "event"+ , request_seqEvaluateResponse :: Int -- ^Sequence number of the corresponding request+ , successEvaluateResponse :: Bool -- ^Outcome of the request+ , commandEvaluateResponse :: String -- ^The command requested + , messageEvaluateResponse :: String -- ^Contains error message if success == false.+ , bodyEvaluateResponse :: EvaluateResponseBody -- The body of EvaluateResponse+ } deriving (Show, Read, Eq)+++-- |+-- Response to "evaluate" request. +--+data EvaluateResponseBody =+ EvaluateResponseBody {+ resultEvaluateResponseBody :: String -- ^The result of the evaluate.+ , typeEvaluateResponseBody :: String -- ^The optional type of the evaluate result. + , presentationHintEvaluateResponseBody :: Maybe VariablePresentationHint -- ^Properties of a evaluate result that can be used to determine how to render the result in the UI.+ , variablesReferenceEvaluateResponseBody :: Int -- ^If variablesReference is > 0, the evaluate result is structured and its children can be retrieved by passing variablesReference to the VariablesRequest.+ , namedVariablesEvaluateResponseBody :: Maybe Int -- ^The number of named child variables. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ , indexedVariablesEvaluateResponseBody :: Maybe Int -- ^The number of indexed child variables. The client can use this optional information to present the variables in a paged UI and fetch them in chunks.+ } deriving (Show, Read, Eq)++-- |+--+defaultEvaluateResponseBody :: EvaluateResponseBody+defaultEvaluateResponseBody = EvaluateResponseBody {+ resultEvaluateResponseBody = ""+ , typeEvaluateResponseBody = ""+ , presentationHintEvaluateResponseBody = Nothing+ , variablesReferenceEvaluateResponseBody = 0+ , namedVariablesEvaluateResponseBody = Nothing+ , indexedVariablesEvaluateResponseBody = Nothing+ }+++----------------------------------------------------------------------------+-- CompletionsRequest+----------------------------------------------------------------------------++-- |+-- CompletionsRequest request; value of command field is 'completions'.+--+-- Returns a list of possible completions for a given caret position and text.+--+-- The CompletionsRequest may only be called if the 'supportsCompletionsRequest' capability exists and is true.+--+data CompletionsRequest =+ CompletionsRequest {+ seqCompletionsRequest :: Int -- ^Sequence number+ , typeCompletionsRequest :: String -- ^One of "request", "response", or "event"+ , commandCompletionsRequest :: String -- ^The command to execute+ , argumentsCompletionsRequest :: CompletionsRequestArguments -- ^Arguments for "completions" request.+ } deriving (Show, Read, Eq)+++-- |+-- Arguments for 'completions' request. +--+data CompletionsRequestArguments =+ CompletionsRequestArguments {+ frameIdCompletionsRequestArguments :: Maybe Int -- ^Returns completions in the scope of this stack frame. If not specified, the completions are returned for the global scope. + , textCompletionsRequestArguments :: String -- ^One or more source lines. Typically this is the text a user has typed into the debug console before he asked for completion.+ , columnCompletionsRequestArguments :: Int -- ^The character position for which to determine the completion proposals. + , lineCompletionsRequestArguments :: Maybe Int -- ^An optional line for which to determine the completion proposals. If missing the first line of the text is assumed.+ } deriving (Show, Read, Eq)+++-- |+-- Response to 'completions' request.+--+data CompletionsResponse =+ CompletionsResponse {+ seqCompletionsResponse :: Int -- ^Sequence number+ , typeCompletionsResponse :: String -- ^One of "request", "response", or "event"+ , request_seqCompletionsResponse :: Int -- ^Sequence number of the corresponding request+ , successCompletionsResponse :: Bool -- ^Outcome of the request+ , commandCompletionsResponse :: String -- ^The command requested + , messageCompletionsResponse :: String -- ^Contains error message if success == false.+ , bodyCompletionsResponse :: CompletionsResponseBody -- ^The body of CompletionsResponse+ } deriving (Show, Read, Eq)+++-- |+--+defaultCompletionsResponse :: CompletionsResponse+defaultCompletionsResponse = CompletionsResponse {+ seqCompletionsResponse = 0+ , typeCompletionsResponse = "response"+ , request_seqCompletionsResponse = 0+ , successCompletionsResponse = False+ , commandCompletionsResponse = "completions"+ , messageCompletionsResponse = ""+ , bodyCompletionsResponse = defaultCompletionsResponseBody+ }++-- |+-- Response to 'completions' request.+--+data CompletionsResponseBody =+ CompletionsResponseBody {+ targetsCompletionsResponseBody :: [CompletionsItem] -- ^The possible completions for .+ } deriving (Show, Read, Eq)+++-- |+--+defaultCompletionsResponseBody :: CompletionsResponseBody+defaultCompletionsResponseBody = CompletionsResponseBody []++-- |+-- CompletionItems are the suggestions returned from the CompletionsRequest.+--+data CompletionsItem =+ CompletionsItem {+ labelCompletionsItem :: String -- ^The label of this completion item. By default this is also the text that is inserted when selecting this completion.+ {-+ , textCompletionsItem :: String -- If text is not falsy then it is inserted instead of the label.+ , typeCompletionsItem :: CompletionItemType -- The item's type. Typically the client uses this information to render the item in the UI with an icon.+ , startCompletionsItem :: Int -- When a completion is selected it replaces 'length' characters starting at 'start' in the text passed to the CompletionsRequest.+ , lengthCompletionsItem :: Int --If missing the frontend will try to determine these values heuristically.+ -}+ } deriving (Show, Read, Eq)+++----------------------------------------------------------------------------+-- Event+----------------------------------------------------------------------------++-- |+-- Event message for "output" event type. The event indicates that the target has produced output.+--+data OutputEvent =+ OutputEvent {+ seqOutputEvent :: Int -- ^Sequence number+ , typeOutputEvent :: String -- ^One of "request", "response", or "event"+ , eventOutputEvent :: String -- ^Type of event+ , bodyOutputEvent :: OutputEventBody -- ^The body of OutputEvent+ } deriving (Show, Read, Eq)++-- |+--+defaultOutputEvent :: OutputEvent+defaultOutputEvent = OutputEvent 0 "event" "output" defaultOutputEventBody+++-- |+-- Event message for "output" event type. The event indicates that the target has produced output.+--+data OutputEventBody =+ OutputEventBody {+ categoryOutputEventBody :: String -- ^The category of output (such as: 'console', 'stdout', 'stderr', 'telemetry'). If not specified, 'console' is assumed. + , outputOutputEventBody :: String -- ^The output to report.+ , dataOutputEventBody :: Maybe String -- ^Optional data to report. For the 'telemetry' category the data will be sent to telemetry, for the other categories the data is shown in JSON format.+ } deriving (Show, Read, Eq)++-- |+--+defaultOutputEventBody :: OutputEventBody+defaultOutputEventBody = OutputEventBody "console" "" Nothing+++-- |+-- Server-initiated response to client request+--+data InitializedEvent =+ InitializedEvent {+ seqInitializedEvent :: Int -- ^Sequence number+ , typeInitializedEvent :: String -- ^One of "request", "response", or "event"+ , eventInitializedEvent :: String -- ^Type of event+ } deriving (Show, Read, Eq)++-- |+--+defaultInitializedEvent :: InitializedEvent+defaultInitializedEvent = InitializedEvent 0 "event" "initialized"+++-- |+-- Event message for "terminated" event types.+--+-- The event indicates that debugging of the debuggee has terminated.+--+data TerminatedEvent =+ TerminatedEvent {+ seqTerminatedEvent :: Int -- ^Sequence number+ , typeTerminatedEvent :: String -- ^One of "request", "response", or "event"+ , eventTerminatedEvent :: String -- ^Type of event+ , bodyTerminatedEvent :: TerminatedEventBody -- ^The body of TerminatedEvent+ } deriving (Show, Read, Eq)+++-- |+--+defaultTerminatedEvent :: TerminatedEvent+defaultTerminatedEvent = TerminatedEvent {+ seqTerminatedEvent = 0+ , typeTerminatedEvent = "event"+ , eventTerminatedEvent = "terminated"+ , bodyTerminatedEvent = defaultTerminatedEventBody+ }++-- |+-- Event message for "terminated" event types.+--+-- The event indicates that debugging of the debuggee has terminated.+--+data TerminatedEventBody =+ TerminatedEventBody {+ restartTerminatedEventBody :: Bool -- ^A debug adapter may set 'restart' to true to request that the front end restarts the session.+ } deriving (Show, Read, Eq)+++-- |+--+defaultTerminatedEventBody :: TerminatedEventBody+defaultTerminatedEventBody = TerminatedEventBody {+ restartTerminatedEventBody = False+ }+++-- |+-- Event message for "exited" event types.+--+data ExitedEvent =+ ExitedEvent {+ seqExitedEvent :: Int -- ^Sequence number+ , typeExitedEvent :: String -- ^One of "request", "response", or "event"+ , eventExitedEvent :: String -- ^Type of event+ , bodyExitedEvent :: ExitedEventBody -- ^The body of TerminatedEvent+ } deriving (Show, Read, Eq)+++-- |+--+defaultExitedEvent :: ExitedEvent+defaultExitedEvent = ExitedEvent {+ seqExitedEvent = 0+ , typeExitedEvent = "event"+ , eventExitedEvent = "exited"+ , bodyExitedEvent = defaultExitedEventBody+ }++-- |+-- Event message for "exited" event types.+--+-- The exit code returned from the debuggee.+--+data ExitedEventBody =+ ExitedEventBody {+ exitCodeExitedEventBody :: Int+ } deriving (Show, Read, Eq)+++-- |+--+defaultExitedEventBody :: ExitedEventBody+defaultExitedEventBody = ExitedEventBody {+ exitCodeExitedEventBody = -1+ }++++-- |+-- Event message for 'continued' event type.+--+-- The event indicates that the execution of the debuggee has continued.+--+-- Please note: a debug adapter is not expected to send this event in response to a request that implies that execution continues, e.g. 'launch' or 'continue'.+--+-- It is only necessary to send a 'continued' event if there was no previous request that implied this.+--+data ContinuedEvent =+ ContinuedEvent {+ seqContinuedEvent :: Int -- ^Sequence number+ , typeContinuedEvent :: String -- ^One of "request", "response", or "event"+ , eventContinuedEvent :: String -- ^Type of event+ , bodyContinuedEvent :: ContinuedEventBody -- ^The body of ContinuedEvent+ } deriving (Show, Read, Eq)+++-- |+--+defaultContinuedEvent :: ContinuedEvent+defaultContinuedEvent = ContinuedEvent {+ seqContinuedEvent = 0+ , typeContinuedEvent = "event"+ , eventContinuedEvent = "continued"+ , bodyContinuedEvent = defaultContinuedEventBody+ }++-- |+-- Body of ContinuedEvent+--+data ContinuedEventBody =+ ContinuedEventBody {+ threadIdContinuedEventBody :: Int -- ^The thread which was continued.+ , allThreadsContinuedContinuedEventBody :: Bool -- ^If 'allThreadsContinued' is true, a debug adapter can announce that all threads have continued.+ } deriving (Show, Read, Eq)+++-- |+--+defaultContinuedEventBody :: ContinuedEventBody+defaultContinuedEventBody = ContinuedEventBody {+ threadIdContinuedEventBody = 0+ , allThreadsContinuedContinuedEventBody = True+ }++++-- |+-- Event message for "stopped" event type.+--+-- The event indicates that the execution of the debuggee has stopped due to some condition.+--+-- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc.+--+data StoppedEvent =+ StoppedEvent {+ seqStoppedEvent :: Int -- ^Sequence number+ , typeStoppedEvent :: String -- ^One of "request", "response", or "event"+ , eventStoppedEvent :: String -- ^Type of event+ , bodyStoppedEvent :: StoppedEventBody -- ^The body of StoppedEvent+ } deriving (Show, Read, Eq)+++-- |+--+defaultStoppedEvent :: StoppedEvent+defaultStoppedEvent = StoppedEvent {+ seqStoppedEvent = 0+ , typeStoppedEvent = "event"+ , eventStoppedEvent = "stopped"+ , bodyStoppedEvent = defaultStoppedEventBody+ }+++-- |+-- Event message for 'stopped' event type.+--+-- The event indicates that the execution of the debuggee has stopped due to some condition.+--+-- This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc.+--+data StoppedEventBody =+ StoppedEventBody {+ reasonStoppedEventBody :: String -- ^The reason for the event.For backward compatibility this string is shown in the UI if the 'description' attribute is missing (but it must not be translated).Values: 'step', 'breakpoint', 'exception', 'pause', 'entry', etc.+ , descriptionStoppedEventBody :: String -- ^The full reason for the event, e.g. 'Paused on exception'. This string is shown in the UI as is.+ , threadIdStoppedEventBody :: Int -- ^The thread which was stopped.+ , textStoppedEventBody :: String -- ^Additional information. E.g. if reason is 'exception', text contains the exception name. This string is shown in the UI. ++ {-|+ If allThreadsStopped is true, a debug adapter can announce that all threads have stopped.+ The client should use this information to enable that all threads can be expanded to access their stacktraces.+ If the attribute is missing or false, only the thread with the given threadId can be expanded.+ -}+ , allThreadsStoppedStoppedEventBody :: Bool+ } deriving (Show, Read, Eq)++-- |+--+defaultStoppedEventBody :: StoppedEventBody+defaultStoppedEventBody = StoppedEventBody {+ reasonStoppedEventBody = "breakpoint"+ , descriptionStoppedEventBody = ""+ , threadIdStoppedEventBody = 0+ , textStoppedEventBody = ""+ , allThreadsStoppedStoppedEventBody = True+ }+
src/GHCi/DAP/IFData.hs view
@@ -5,6 +5,10 @@ Copyright : 2017-2018 phoityne_hs License : BSD3 +__This module will be deprecated.__++__@see : GHCi.DAP module.__+ Implementation of DAP interface data type. @see : https://github.com/Microsoft/vscode-debugadapter-node/blob/master/protocol/src/debugProtocol.ts@@ -484,7 +488,6 @@ -- | ---defaultStackFrame :: StackFrame defaultStackFrame = StackFrame { idStackFrame = 0 , nameStackFrame = ""