ghci-dap 0.0.11.0 → 0.0.12.0
raw patch · 19 files changed
+1674/−1733 lines, 19 files
Files
- Changelog.md +4/−0
- README.md +3/−3
- app-ghc-8.4/GHCMain.hs +14/−13
- app-ghc-8.4/GHCi/UI.hs +17/−39
- app-ghc-8.4/GHCi/UI/Monad.hs +7/−8
- app-ghc-8.6/GHCMain.hs +15/−14
- app-ghc-8.6/GHCi/UI.hs +18/−42
- app-ghc-8.6/GHCi/UI/Monad.hs +7/−8
- app/GHCi/DAP/Command.hs +1046/−1483
- app/GHCi/DAP/Constant.hs +0/−5
- app/GHCi/DAP/Type.hs +30/−12
- app/GHCi/DAP/UI.hs +67/−0
- app/GHCi/DAP/Utility.hs +436/−31
- app/Main.hs +1/−1
- ghci-dap.cabal +3/−3
- src-c-8.4/HsVersions.h +2/−2
- src-c-8.4/hschooks.c +2/−2
- src-c-8.6/HsVersions.h +0/−65
- src-c-8.6/hschooks.c +2/−2
Changelog.md view
@@ -1,5 +1,9 @@ +20190402 ghci-dap-0.0.12.0+ * [INFO] support haskell-dap-0.0.11.0.++ 20190301 ghci-dap-0.0.11.0 * [INFO] start developping, based on haskell-dap-0.0.10.0.
README.md view
@@ -7,8 +7,7 @@  Started developing based on [haskell-dap-0.0.10.0](https://hackage.haskell.org/package/haskell-dap). -Separated an interface package and a implementation package.-+Separated an implementation from the interface package. # Requirement - haskell-dap@@ -21,5 +20,6 @@ # Limitation Currently this project is an __experimental__ design and implementation. -* Dev and checked on windows10 ghc-8.4+* Supported ghc-8.6, ghc-8.4+* Dev and checked on windows10
app-ghc-8.4/GHCMain.hs view
@@ -9,7 +9,7 @@ -- ----------------------------------------------------------------------------- -module GHCMain (ghcMain) where+module GHCMain (ghcMain) where -- DAP Modified -- The official GHC API import qualified GHC@@ -26,7 +26,7 @@ import DriverMkDepend ( doMkDependHS ) import DriverBkp ( doBackpack ) #if defined(GHCI)-import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings )+import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings ) -- DAP Modified #endif -- Frontend plugins@@ -74,6 +74,7 @@ import Data.List import Data.Maybe +-- DAP add import qualified GHC.Paths -----------------------------------------------------------------------------@@ -88,8 +89,8 @@ ----------------------------------------------------------------------------- -- GHC's command-line interface -ghcMain :: GhciSettings -> IO ()-ghcMain setting = do+ghcMain :: GhciSettings -> IO () -- DAP Modified+ghcMain setting = do -- DAP Modified initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -111,7 +112,7 @@ argv0 <- getArgs let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0- mbMinusB | null minusB_args = Just GHC.Paths.libdir+ mbMinusB | null minusB_args = Just GHC.Paths.libdir -- DAP Modified | otherwise = Just (drop 2 (last minusB_args)) let argv2 = map (mkGeneralLocated "on the commandline") argv1@@ -149,11 +150,11 @@ ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode ->- main' setting postLoadMode dflags argv3 flagWarnings+ main' setting postLoadMode dflags argv3 flagWarnings -- DAP Modified -main' :: GhciSettings -> PostLoadMode -> DynFlags -> [Located String] -> [Warn]+main' :: GhciSettings -> PostLoadMode -> DynFlags -> [Located String] -> [Warn] -- DAP Modified -> Ghc ()-main' setting postLoadMode dflags0 args flagWarnings = do+main' setting postLoadMode dflags0 args flagWarnings = do -- DAP Modified -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -256,8 +257,8 @@ DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs)- DoInteractive -> ghciUI setting srcs Nothing- DoEval exprs -> ghciUI setting srcs $ Just $ reverse exprs+ DoInteractive -> ghciUI setting srcs Nothing -- DAP Modified+ DoEval exprs -> ghciUI setting srcs $ Just $ reverse exprs -- DAP Modified DoAbiHash -> abiHash (map fst srcs) ShowPackages -> liftIO $ showPackages dflags6 DoFrontend f -> doFrontend f srcs@@ -265,11 +266,11 @@ liftIO $ dumpFinalStats dflags6 -ghciUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+ghciUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () -- DAP Modified #if !defined(GHCI)-ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use") -- DAP Modified #else-ghciUI = interactiveUI+ghciUI = interactiveUI -- DAP Modified #endif -- -----------------------------------------------------------------------------
app-ghc-8.4/GHCi/UI.hs view
@@ -23,19 +23,24 @@ module GHCi.UI ( interactiveUI, GhciSettings(..),+ -- defaultGhciSettings, -- DAP Modified ghciCommands, ghciWelcomeMsg, - -- haskell-dap add.+ -- DAP add. defaultGhciSettings, getLoadedModules, breakCmd, deleteCmd,+ backCmd,+ forwardCmd,+ historyCmd, traceCmd, stepCmd, stepLocalCmd, runStmt,- toBreakIdAndLocation+ toBreakIdAndLocation,+ forceCmd ) where #include "HsVersions.h"@@ -148,8 +153,7 @@ -- DAP ------------------------------------------------------------------------------ import qualified GHCi.DAP.Type as DAP-import InteractiveEval (ExecResult)-import Control.Concurrent+import qualified GHCi.DAP.UI as DAP -----------------------------------------------------------------------------@@ -610,7 +614,7 @@ -- 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)+ is_tty <- liftIO (return True) -- DAP modified. let show_prompt = verbosity dflags > 0 || is_tty -- reset line number@@ -3257,7 +3261,7 @@ = withSandboxOnly ":trace" $ tr arg where tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >>= saveTraceCmdExecResult >> return ()+ tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.setContinueExecResult >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -3266,7 +3270,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do runResult <- resume pre step- saveDoContinueExecResult runResult+ DAP.setContinueExecResult (Just runResult) _ <- afterRunStmt pre runResult return () @@ -3318,6 +3322,8 @@ (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..."+ + DAP.setStackTraceResult r took bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold@@ -3336,6 +3342,7 @@ -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st]+ DAP.setBindingNames names forwardCmd :: String -> GHCi () forwardCmd arg@@ -3353,6 +3360,9 @@ st <- getGHCiState enqueueCommands [stop st] + DAP.setBindingNames names++ -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine@@ -3840,36 +3850,4 @@ 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-ghc-8.4/GHCi/UI/Monad.hs view
@@ -30,7 +30,7 @@ mkEvalWrapper ) where --- #include "HsVersions.h"+-- #include "HsVersions.h" -- DAP Modified import GHCi.UI.Info (ModInfo) import qualified GHC@@ -64,6 +64,7 @@ import Data.Map.Strict (Map) import qualified GHC.LanguageExtensions as LangExt +-- DAP add. import qualified GHCi.DAP.Type as DAP import Control.Concurrent @@ -344,7 +345,7 @@ runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult) runStmt expr step = do st <- getGHCiState- GHC.handleSourceError (\e -> do GHC.printException e; saveRunStmtDeclException e; return Nothing) $ do+ GHC.handleSourceError (\e -> do GHC.printException e; dapSaveRunStmtDeclException e; return Nothing) $ do let opts = GHC.execOptions { GHC.execSourceFile = progname st , GHC.execLineNumber = line_number st@@ -361,7 +362,7 @@ withArgs (args st) $ reflectGHCi x $ do GHC.handleSourceError (\e -> do GHC.printException e;- saveRunStmtDeclException e;+ dapSaveRunStmtDeclException e; return Nothing) $ do r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls return (Just r)@@ -482,13 +483,11 @@ -- | ---saveRunStmtDeclException :: SourceError -> GHCi SourceError-saveRunStmtDeclException res = do+dapSaveRunStmtDeclException :: SourceError -> GHCi SourceError+dapSaveRunStmtDeclException res = do mvarCtx <- dapContextGHCiState <$> getGHCiState ctx <- liftIO $ takeMVar mvarCtx- let cur = DAP.runStmtDeclExceptionDAPContext ctx-- liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = res : cur}+ liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res} return res
app-ghc-8.6/GHCMain.hs view
@@ -9,7 +9,7 @@ -- ----------------------------------------------------------------------------- -module GHCMain (ghcMain) where+module GHCMain (ghcMain) where -- DAP Modified -- The official GHC API import qualified GHC@@ -26,7 +26,7 @@ import DriverMkDepend ( doMkDependHS ) import DriverBkp ( doBackpack ) #if defined(GHCI)-import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings )+import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings ) -- DAP Modified #endif -- Frontend plugins@@ -76,6 +76,7 @@ import Data.List import Data.Maybe +-- DAP add import qualified GHC.Paths -----------------------------------------------------------------------------@@ -90,8 +91,8 @@ ----------------------------------------------------------------------------- -- GHC's command-line interface -ghcMain :: GhciSettings -> IO ()-ghcMain setting = do+ghcMain :: GhciSettings -> IO () -- DAP Modified+ghcMain setting = do -- DAP Modified initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -102,7 +103,7 @@ argv0 <- getArgs let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0- mbMinusB | null minusB_args = Just GHC.Paths.libdir+ mbMinusB | null minusB_args = Just GHC.Paths.libdir -- DAP Modified | otherwise = Just (drop 2 (last minusB_args)) let argv2 = map (mkGeneralLocated "on the commandline") argv1@@ -140,11 +141,11 @@ ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode ->- main' setting postLoadMode dflags argv3 flagWarnings+ main' setting postLoadMode dflags argv3 flagWarnings -- DAP Modified -main' :: GhciSettings -> PostLoadMode -> DynFlags -> [Located String] -> [Warn]+main' :: GhciSettings -> PostLoadMode -> DynFlags -> [Located String] -> [Warn] -- DAP Modified -> Ghc ()-main' setting postLoadMode dflags0 args flagWarnings = do+main' setting postLoadMode dflags0 args flagWarnings = do -- DAP Modified -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -247,8 +248,8 @@ DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs)- DoInteractive -> ghciUI setting hsc_env dflags6 srcs Nothing- DoEval exprs -> ghciUI setting hsc_env dflags6 srcs $ Just $+ DoInteractive -> ghciUI setting hsc_env dflags6 srcs Nothing -- DAP Modified+ DoEval exprs -> ghciUI setting hsc_env dflags6 srcs $ Just $ -- DAP Modified reverse exprs DoAbiHash -> abiHash (map fst srcs) ShowPackages -> liftIO $ showPackages dflags6@@ -257,16 +258,16 @@ liftIO $ dumpFinalStats dflags6 -ghciUI :: GhciSettings -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]+ghciUI :: GhciSettings -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String] -- DAP Modified -> Ghc () #if !defined(GHCI)-ghciUI _ _ _ _ _ =+ghciUI _ _ _ _ _ = -- DAP Modified throwGhcException (CmdLineError "not built for interactive use") #else-ghciUI setting hsc_env dflags0 srcs maybe_expr = do+ghciUI st hsc_env dflags0 srcs maybe_expr = do -- DAP Modified dflags1 <- liftIO (initializePlugins hsc_env dflags0) _ <- GHC.setSessionDynFlags dflags1- interactiveUI setting srcs maybe_expr+ interactiveUI st srcs maybe_expr -- DAP Modified #endif -- -----------------------------------------------------------------------------
app-ghc-8.6/GHCi/UI.hs view
@@ -23,18 +23,23 @@ module GHCi.UI ( interactiveUI, GhciSettings(..),- defaultGhciSettings,+ -- defaultGhciSettings, -- DAP Modified ghciCommands, ghciWelcomeMsg,- -- haskell-dap add.+ -- DAP add.+ defaultGhciSettings, getLoadedModules, breakCmd, deleteCmd,+ backCmd,+ forwardCmd,+ historyCmd, traceCmd, stepCmd, stepLocalCmd, runStmt,- toBreakIdAndLocation+ toBreakIdAndLocation,+ forceCmd ) where #include "HsVersions.h"@@ -153,9 +158,7 @@ -- DAP ------------------------------------------------------------------------------ import qualified GHCi.DAP.Type as DAP-import InteractiveEval (ExecResult)-import Control.Concurrent-+import qualified GHCi.DAP.UI as DAP ----------------------------------------------------------------------------- @@ -617,7 +620,7 @@ -- 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)+ is_tty <- liftIO (return True) -- DAP modified. let show_prompt = verbosity dflags > 0 || is_tty -- reset line number@@ -3318,7 +3321,7 @@ = withSandboxOnly ":trace" $ tr arg where tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >>= saveTraceCmdExecResult >> return ()+ tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.setContinueExecResult >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -3327,7 +3330,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do runResult <- resume pre step- saveDoContinueExecResult runResult+ DAP.setContinueExecResult (Just runResult) _ <- afterRunStmt pre runResult return () @@ -3379,6 +3382,8 @@ (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..."+ + DAP.setStackTraceResult r took bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold@@ -3397,6 +3402,7 @@ -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st]+ DAP.setBindingNames names forwardCmd :: String -> GHCi () forwardCmd arg@@ -3414,6 +3420,9 @@ st <- getGHCiState enqueueCommands [stop st] + DAP.setBindingNames names++ -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine@@ -3901,36 +3910,3 @@ 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-ghc-8.6/GHCi/UI/Monad.hs view
@@ -30,7 +30,7 @@ mkEvalWrapper ) where --- #include "HsVersions.h"+-- #include "HsVersions.h" -- DAP Modified import GHCi.UI.Info (ModInfo) import qualified GHC@@ -64,6 +64,7 @@ import Data.Map.Strict (Map) import qualified GHC.LanguageExtensions as LangExt +-- DAP add. import qualified GHCi.DAP.Type as DAP import Control.Concurrent @@ -344,7 +345,7 @@ runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult) runStmt expr step = do st <- getGHCiState- GHC.handleSourceError (\e -> do GHC.printException e; saveRunStmtDeclException e; return Nothing) $ do+ GHC.handleSourceError (\e -> do GHC.printException e; dapSaveRunStmtDeclException e; return Nothing) $ do let opts = GHC.execOptions { GHC.execSourceFile = progname st , GHC.execLineNumber = line_number st@@ -361,7 +362,7 @@ withArgs (args st) $ reflectGHCi x $ do GHC.handleSourceError (\e -> do GHC.printException e;- saveRunStmtDeclException e;+ dapSaveRunStmtDeclException e; return Nothing) $ do r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls return (Just r)@@ -482,13 +483,11 @@ -- | ---saveRunStmtDeclException :: SourceError -> GHCi SourceError-saveRunStmtDeclException res = do+dapSaveRunStmtDeclException :: SourceError -> GHCi SourceError+dapSaveRunStmtDeclException res = do mvarCtx <- dapContextGHCiState <$> getGHCiState ctx <- liftIO $ takeMVar mvarCtx- let cur = DAP.runStmtDeclExceptionDAPContext ctx-- liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = res : cur}+ liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res} return res
app/GHCi/DAP/Command.hs view
@@ -2,1487 +2,1050 @@ module GHCi.DAP.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 Haskell.DAP as D-import GHCi.DAP.Type-import GHCi.DAP.Constant-import GHCi.DAP.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.frameIdScopesRequestArguments args- getScopesResponseBody idx-- -- |- --- getScopesResponseBody :: Int -> GHCi.GHCi (Either String D.ScopesResponseBody)- getScopesResponseBody curIdx = do- -- liftIO $ putStrLn $ "[DAP][getScopesResponseBody] frame id." ++ frameIdStr- oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar- let moveIdx = curIdx - oldIdx-- tyThings <- withMoveIdx moveIdx- gobalTT <- getGlobalBindings-- -- liftIO $ putStrLn $ "[DAP][getScopesResponseBody] 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.ScopesResponseBody {- D.scopesScopesResponseBody = [- 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][getScopesResponseBody] 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.sourceSetBreakpointsRequestArguments 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.SetBreakpointsRequestArguments -> ModuleName -> GHCi.GHCi (Either String D.SetBreakpointsResponseBody)- addBreakpoints args mod = do- let srcBPs = D.breakpointsSetBreakpointsRequestArguments 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.SetFunctionBreakpointsRequestArguments -> GHCi.GHCi (Either String D.SetFunctionBreakpointsResponseBody)- addBreakpoints args = do- let funcBPs = D.breakpointsSetFunctionBreakpointsRequestArguments 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.ContinueRequestArguments -> GHCi.GHCi (Either String D.StoppedEventBody)- withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr- withArgs (Right args) = case D.exprContinueRequestArguments 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.resultEvaluateResponseBody 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.typeEvaluateResponseBody res) $- liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res- return $ Just ("False" == D.resultEvaluateResponseBody 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.typeEvaluateResponseBody res) $- liftIO $ putStrLn $ "[DAP][ERROR] condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res- return $ Just ("False" == D.resultEvaluateResponseBody 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.resultEvaluateResponseBody 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.resultEvaluateResponseBody body- , D.textStoppedEventBody = D.resultEvaluateResponseBody body- }--{-do- evalBody <- getEvalBody "_exception" True- return $ Right D.defaultStoppedEventBody {- D.reasonStoppedEventBody = "exception"- , D.descriptionStoppedEventBody = D.resultEvaluateResponseBody evalBody- , D.textStoppedEventBody = D.resultEvaluateResponseBody 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.NextRequestArguments -> 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.StepInRequestArguments -> 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.StackTraceRequestArguments -> GHCi.GHCi (Either String D.StackTraceResponseBody)- 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.defaultStackTraceResponseBody {- D.stackFramesStackTraceResponseBody = traces- , D.totalFramesStackTraceResponseBody = 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.defaultStackTraceResponseBody {- D.stackFramesStackTraceResponseBody = traces- , D.totalFramesStackTraceResponseBody = 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.VariablesRequestArguments -> GHCi.GHCi (Either String D.VariablesResponseBody)- withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr- withArgs (Right args) = do- let idx = D.variablesReferenceVariablesRequestArguments args-- vals <- getBindingVariables ctxMVar idx-- return $ Right $ D.VariablesResponseBody $ 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.EvaluateRequestArguments -> GHCi.GHCi (Either String D.EvaluateResponseBody)- withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr- withArgs (Right args) = case D.contextEvaluateRequestArguments args of- Nothing -> runRepl args- Just "repl" -> runRepl args- _ -> runOther args-- -- |- --- runRepl :: D.EvaluateRequestArguments -> GHCi.GHCi (Either String D.EvaluateResponseBody)- runRepl args- | null (D.expressionEvaluateRequestArguments args) = return $ Right D.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = "no input."- , D.typeEvaluateResponseBody = "no input."- , D.variablesReferenceEvaluateResponseBody = 0- }- | otherwise = do- let stmt = D.expressionEvaluateRequestArguments args- isRefable = True-- runStmtDAP ctxMVar isRefable stmt-- -- |- --- runOther :: D.EvaluateRequestArguments -> GHCi.GHCi (Either String D.EvaluateResponseBody)- runOther args = do - let nameStr = D.expressionEvaluateRequestArguments args- names <- gcatch (GHC.parseName nameStr) parseNameErrorHandler- names2EvalBody ctxMVar True nameStr names----- |----runStmtDAP :: MVar DAPContext -> Bool -> String -> GHCi.GHCi (Either String D.EvaluateResponseBody)-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.EvaluateResponseBody)-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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = showSDoc dflags (ppr x)- , D.typeEvaluateResponseBody = showSDoc dflags (ppr x)- , D.variablesReferenceEvaluateResponseBody = 0- }-- -- |- -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html- --- withTerm :: GHC.Id -> Term -> GHCi.GHCi D.EvaluateResponseBody- 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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = delDQ typeStr valStr'- , D.typeEvaluateResponseBody = typeStr- , D.variablesReferenceEvaluateResponseBody = 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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = valStr- , D.typeEvaluateResponseBody = typeStr- , D.variablesReferenceEvaluateResponseBody = 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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = typeStr- , D.typeEvaluateResponseBody = typeStr- , D.variablesReferenceEvaluateResponseBody = 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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = valStr- , D.typeEvaluateResponseBody = typeStr- , D.variablesReferenceEvaluateResponseBody = 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.defaultEvaluateResponseBody {- D.resultEvaluateResponseBody = valStr- , D.typeEvaluateResponseBody = typeStr- , D.variablesReferenceEvaluateResponseBody = 0- }-- delDQ :: String -> String -> String- delDQ typ val- | (typ == "[Char]" || typ == "String")- && length val > 2- && head val == '"' && last val == '"' = tail $ init val - | otherwise = val+import qualified GHC as G+import GhcMonad+import HscTypes+import RdrName+import Outputable+import Exception+import FastString+import DataCon+import DynFlags+import RtClosureInspect+import qualified GHCi.UI as Gi+import qualified GHCi.UI.Monad as Gi hiding (runStmt)++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 Haskell.DAP as D+import GHCi.DAP.Type+import GHCi.DAP.Constant+import GHCi.DAP.Utility+++-- |+--+dapCommands :: [Gi.Command]+dapCommands = map mkCmd [+ ("dap-launch", dapCmdRunner launchCmd, noCompletion)+ , ("dap-set-breakpoints", dapCmdRunner setBpCmd, noCompletion)+ , ("dap-set-function-breakpoints", dapCmdRunner setFuncBpsCmd, noCompletion)+ , ("dap-set-function-breakpoint", dapCmdRunner setFuncBpCmd, noCompletion)+ , ("dap-delete-breakpoint", dapCmdRunner delBpCmd, noCompletion)+ , ("dap-stacktrace", dapCmdRunner dapStackTraceCmd, noCompletion)+ , ("dap-scopes", dapCmdRunner dapScopesCmd, noCompletion)+ , ("dap-variables", dapCmdRunner dapVariablesCmd, noCompletion)+ , ("dap-evaluate", dapCmdRunner dapEvalCmd, noCompletion)+ , ("dap-continue", dapCmdRunner dapContinueCmd, noCompletion)+ , ("dap-next", dapCmdRunner nextCmd, noCompletion)+ , ("dap-step-in", dapCmdRunner stepInCmd, noCompletion)+ ]+ where+ mkCmd :: (String, String -> InputT Gi.GHCi Bool, CompletionFunc Gi.GHCi)+ -> Gi.Command+ mkCmd (n,a,c) = Gi.Command {+ Gi.cmdName = n+ , Gi.cmdAction = a+ , Gi.cmdHidden = False+ , Gi.cmdCompletionFunc = c+ }++ -- |+ --+ dapCmdRunner :: (String -> Gi.GHCi ())+ -> String+ -> InputT Gi.GHCi Bool+ dapCmdRunner cmd str = do+ + lift $ cmd str++ return False+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-launch+------------------------------------------------------------------------------------------------+-- |+--+launchCmd :: String -> Gi.GHCi ()+launchCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= launchCmd_+ >>= printDAP++-- |+-- +launchCmd_ :: D.LaunchRequestArguments+ -> Gi.GHCi (Either String ())+launchCmd_ arg = do+ setLogLevel+ setForceInspect+ return $ Right ()+ where+ -- |+ -- + setLogLevel :: Gi.GHCi ()+ setLogLevel = do+ let lv = case D.logLevelLaunchRequestArguments arg of+ "EMERGENCY" -> ErrorLogLevel+ "ALERT" -> ErrorLogLevel+ "CRITICAL" -> ErrorLogLevel+ "ERROR" -> ErrorLogLevel+ "WARNING" -> WarnLogLevel+ "NOTICE" -> WarnLogLevel+ "INFO" -> InfoLogLevel+ "DEBUG" -> DebugLogLevel+ _ -> WarnLogLevel++ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {logLevelDAPContext = lv}++ -- |+ -- + setForceInspect :: Gi.GHCi ()+ setForceInspect = do+ let isForce = case D.forceInspectLaunchRequestArguments arg of+ Nothing -> False+ Just a -> a++ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {isInspectVariableDAPContext = isForce}++ +------------------------------------------------------------------------------------------------+-- DAP Command :dap-set-breakpoints+------------------------------------------------------------------------------------------------+-- |+--+setBpCmd :: String -> Gi.GHCi ()+setBpCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= setBpCmd_+ >>= printDAP++-- |+-- +setBpCmd_ :: D.SetBreakpointsRequestArguments+ -> Gi.GHCi (Either String D.SetBreakpointsResponseBody)+setBpCmd_ args =+ deleteBreakpoints >> addBreakpoints+ + where+ -- |+ -- + deleteBreakpoints :: Gi.GHCi ()+ deleteBreakpoints = do+ bps <- getDelBPs+ debugL $ "<dapSetBreakpointsCommand> delete src bps " ++ show bps+ mapM_ delBreakpoint bps++ -- |+ -- + addBreakpoints :: Gi.GHCi (Either String D.SetBreakpointsResponseBody)+ addBreakpoints = do+ let srcBPs = D.breakpointsSetBreakpointsRequestArguments args+ addBps <- mapM addBP srcBPs+ updateBpCtx addBps+ return $ Right $ D.SetBreakpointsResponseBody $ map takeBp addBps++ -- |+ --+ getDelBPs :: Gi.GHCi [Int]+ getDelBPs = do+ mod <- getModule+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let bpNOs = M.keys $ M.filter ((isModuleMatch mod)) $ srcBPsDAPContext ctx+ newSrcBPs = M.filter (not . (isModuleMatch mod)) $ srcBPsDAPContext ctx++ liftIO $ putMVar ctxMVar $ ctx {srcBPsDAPContext = newSrcBPs} + return bpNOs++ -- |+ --+ isModuleMatch :: ModuleName -> SourceBreakpointInfo -> Bool+ isModuleMatch mod bpInfo = mod == modNameSourceBreakpointInfo bpInfo++ -- |+ -- + getModule :: Gi.GHCi ModuleName+ getModule = do+ let srcInfo = D.sourceSetBreakpointsRequestArguments args+ srcPath = D.pathSource srcInfo++ modSums <- Gi.getLoadedModules+ let modPaths = map takeModPath modSums++ case filter (isPathMatch srcPath) modPaths of+ ((m, p):[]) -> do+ debugL $ "<dapSetBreakpointsCommand> " ++ p ++ " -> " ++ m+ return m++ _ -> throwError $ "loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths++ -- |+ --+ takeModPath :: ModSummary -> (String, FilePath)+ takeModPath ms = (G.moduleNameString (G.ms_mod_name ms), G.ms_hspp_file ms)++ -- |+ --+ isPathMatch :: FilePath -> (String, FilePath) -> Bool+ isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)++ -- |+ --+ addBP :: D.SourceBreakpoint -> Gi.GHCi (ModuleName, D.SourceBreakpoint, D.Breakpoint)+ addBP srcBP = do+ mod <- getModule+ 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)] -> Gi.GHCi ()+ updateBpCtx bps = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let cur = srcBPsDAPContext ctx+ new = M.fromList $ foldr convSrcBps [] bps+ liftIO $ 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+------------------------------------------------------------------------------------------------+-- |+--+setFuncBpsCmd :: String -> Gi.GHCi ()+setFuncBpsCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= setFuncBpsCmd_+ >>= printDAP++-- |+--+setFuncBpsCmd_ :: D.SetFunctionBreakpointsRequestArguments+ -> Gi.GHCi (Either String D.SetFunctionBreakpointsResponseBody)+setFuncBpsCmd_ args = deleteBreakpoints >> addBreakpoints+ where++ -- |+ --+ deleteBreakpoints :: Gi.GHCi ()+ deleteBreakpoints = do+ bps <- getDelBPs+ debugL $ "<dapSetFunctionBreakpointsCommand> delete func bps " ++ show bps+ mapM_ delBreakpoint bps+ + -- |+ --+ addBreakpoints :: Gi.GHCi (Either String D.SetFunctionBreakpointsResponseBody)+ addBreakpoints = do+ let funcBPs = D.breakpointsSetFunctionBreakpointsRequestArguments args++ addBps <- mapM addBP funcBPs+ updateBpCtx addBps+ return $ Right $ D.SetFunctionBreakpointsResponseBody $ map snd addBps++ -- |+ --+ getDelBPs :: Gi.GHCi [Int]+ getDelBPs = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let bpNOs = M.keys $ funcBPsDAPContext ctx++ liftIO $ putMVar ctxMVar $ ctx {funcBPsDAPContext = M.fromList []} + return bpNOs++ -- |+ --+ addBP :: D.FunctionBreakpoint -> Gi.GHCi (D.FunctionBreakpoint, D.Breakpoint)+ addBP funcBP = do+ let argStr = D.nameFunctionBreakpoint funcBP+ bp <- addBreakpoint argStr+ return (funcBP, bp)++ -- |+ --+ updateBpCtx :: [(D.FunctionBreakpoint, D.Breakpoint)] -> Gi.GHCi ()+ updateBpCtx bps = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let new = foldr getBpNo [] bps+ liftIO $ 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+------------------------------------------------------------------------------------------------+-- |+--+setFuncBpCmd :: String -> Gi.GHCi ()+setFuncBpCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= setFuncBpCmd_+ >>= printDAP++-- |+--+setFuncBpCmd_ :: (FilePath, D.FunctionBreakpoint)+ -> Gi.GHCi (Either String D.Breakpoint)+setFuncBpCmd_ (startup, funcBP) = do+ modName <- getModuleByFile+ let funcName = D.nameFunctionBreakpoint funcBP+ argStr = modName ++ "." ++ funcName++ bp <- addBreakpoint argStr+ updateBpCtx (funcBP, bp)++ return $ Right bp+ + where+ -- |+ --+ getModuleByFile :: Gi.GHCi String+ getModuleByFile = do+ modSums <- Gi.getLoadedModules+ let modPaths = map takeModPath modSums++ case filter (isPathMatch startup) modPaths of+ ((m, p):[]) -> do+ debugL $ "<dapSetFuncBreakpointCommand> " ++ p ++ " -> " ++ m+ return m+ _ -> throwError $ "loaded module can not find from path. <" ++ startup ++ "> " ++ show modPaths++ -- |+ --+ updateBpCtx :: (D.FunctionBreakpoint, D.Breakpoint) -> Gi.GHCi ()+ updateBpCtx (funcBP, bp) = case D.idBreakpoint bp of+ Nothing -> throwError "breakpoint number not found."+ Just no -> do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let funcBpMap = funcBPsDAPContext ctx++ liftIO $ putMVar ctxMVar $ ctx{funcBPsDAPContext = M.insert no (funcBP, 0) funcBpMap}+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-delete-breakpoint+------------------------------------------------------------------------------------------------+-- |+--+delBpCmd :: String -> Gi.GHCi ()+delBpCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= delBpCmd_+ >>= printDAP++-- |+--+delBpCmd_ :: D.Breakpoint -> Gi.GHCi (Either String ())+delBpCmd_ D.Breakpoint{D.idBreakpoint = Nothing} = throwError "breakpoint number not found."+delBpCmd_ D.Breakpoint{D.idBreakpoint = Just bid} = do+ delBreakpoint bid+ updateBpCtx+ return $ Right ()+ where+ -- |+ --+ updateBpCtx :: Gi.GHCi ()+ updateBpCtx = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let funcBpMap = funcBPsDAPContext ctx++ liftIO $ putMVar ctxMVar $ ctx{funcBPsDAPContext = M.delete bid funcBpMap}+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-stacktrace+------------------------------------------------------------------------------------------------+-- |+--+dapStackTraceCmd :: String -> Gi.GHCi ()+dapStackTraceCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= dapStackTraceCmd_+ >>= printDAP++-- |+--+dapStackTraceCmd_ :: D.StackTraceRequestArguments+ -> Gi.GHCi (Either String D.StackTraceResponseBody)+dapStackTraceCmd_ _ = do+ clearStackTraceResult++ Gi.historyCmd ""+ + getStackTraceResult >>= \case+ Nothing -> throwError $ "no stacktrace found."+ Just res -> withResult res++ where++ -- | + --+ clearStackTraceResult :: Gi.GHCi ()+ clearStackTraceResult = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {stackTraceResultDAPContext = Nothing}++ -- | + --+ getStackTraceResult :: Gi.GHCi (Maybe (G.Resume, [G.History]))+ getStackTraceResult = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ return $ stackTraceResultDAPContext ctx++ -- |+ --+ withResult :: (G.Resume, [G.History]) -> Gi.GHCi (Either String D.StackTraceResponseBody)+ withResult (r, hs) = do+ hists <- mapM resumeHist2stackFrame hs+ let traces = if isExceptionResume r+ then hists+ else resume2stackframe r : hists+ let traceWithId = setFrameIdx 0 traces++ return $ Right D.defaultStackTraceResponseBody {+ D.stackFramesStackTraceResponseBody = traceWithId+ , D.totalFramesStackTraceResponseBody = length traceWithId+ }++ -- |+ --+ resumeHist2stackFrame :: G.History -> Gi.GHCi D.StackFrame+ resumeHist2stackFrame hist= do+ span <- G.getHistorySpan hist+ let name = L.intercalate ":" (G.historyEnclosingDecls hist)++ return $ genStackFrame span name++ -- |+ --+ resume2stackframe :: G.Resume -> D.StackFrame+ resume2stackframe r = genStackFrame (G.resumeSpan r) (getStackFrameTitle r)++ -- |+ --+ setFrameIdx :: Int -> [D.StackFrame] -> [D.StackFrame]+ setFrameIdx _ [] = []+ setFrameIdx idx (x:xs) = x{D.idStackFrame = idx} : setFrameIdx (idx+1) xs++ -- |+ --+ getStackFrameTitle :: G.Resume -> String+ getStackFrameTitle r = maybe "unknown" (G.moduleNameString . G.moduleName . G.breakInfo_module) (G.resumeBreakInfo r)+ ++ "."+ ++ G.resumeDecl r++ -- |+ --+ genStackFrame :: G.SrcSpan -> String -> D.StackFrame+ genStackFrame (G.RealSrcSpan dat) name = D.defaultStackFrame {+ D.idStackFrame = 0+ , D.nameStackFrame = name+ , D.sourceStackFrame = D.defaultSource {D.pathSource = (unpackFS . G.srcSpanFile) dat}+ , D.lineStackFrame = G.srcSpanStartLine dat+ , D.columnStackFrame = G.srcSpanStartCol dat+ , D.endLineStackFrame = G.srcSpanEndLine dat+ , D.endColumnStackFrame = G.srcSpanEndCol dat+ }+ genStackFrame (G.UnhelpfulSpan _) name = D.defaultStackFrame {+ D.idStackFrame = 0+ , D.nameStackFrame = name+ , D.sourceStackFrame = D.defaultSource {D.pathSource = "UnhelpfulSpan"}+ , D.lineStackFrame = 0+ , D.columnStackFrame = 0+ , D.endLineStackFrame = 0+ , D.endColumnStackFrame = 0+ }+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-scopes+------------------------------------------------------------------------------------------------+-- |+--+dapScopesCmd :: String -> Gi.GHCi ()+dapScopesCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= dapScopesCmd_+ >>= printDAP++-- |+--+dapScopesCmd_ :: D.ScopesRequestArguments+ -> Gi.GHCi (Either String D.ScopesResponseBody)+dapScopesCmd_ args = moveScope >> makeResponse++ where+ -- |+ --+ moveScope :: Gi.GHCi ()+ moveScope = do+ let curIdx = D.frameIdScopesRequestArguments args+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar+ let moveIdx = curIdx - oldIdx++ tyThings <- withMoveIdx moveIdx+ gobalTT <- getGlobalBindings++ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {+ variableReferenceMapDAPContext = M.empty+ , bindingDAPContext = tyThings+ , bindingGlobalDAPContext = gobalTT+ , frameIdDAPContext = curIdx+ }++ -- |+ --+ makeResponse :: Gi.GHCi (Either String D.ScopesResponseBody)+ makeResponse = return $ Right D.ScopesResponseBody {+ D.scopesScopesResponseBody = [+ 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 :: Int -> Gi.GHCi [TyThing]+ withMoveIdx moveIdx+ | 0 == moveIdx = G.getBindings+ | 0 < moveIdx = back moveIdx+ | otherwise = forward (negate moveIdx)+ + -- |+ --+ getGlobalBindings :: Gi.GHCi [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 :: Int -> Gi.GHCi [TyThing]+ back num = do+ clearBindingNames+ Gi.backCmd $ show num+ names <- getBindingNames+ foldM withName [] $ reverse names++ -- |+ --+ forward :: Int -> Gi.GHCi [TyThing]+ forward num = do+ clearBindingNames+ Gi.forwardCmd $ show num+ names <- getBindingNames+ foldM withName [] $ reverse names++ -- |+ --+ withName :: [TyThing] -> G.Name -> Gi.GHCi [TyThing]+ withName acc n = G.lookupName n >>= \case+ Just ty -> return (ty : acc)+ Nothing -> do+ dflags <- getDynFlags+ errorL $ "variable not found. " ++ showSDoc dflags (ppr n)+ return acc+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-variables+------------------------------------------------------------------------------------------------+-- |+--+dapVariablesCmd :: String -> Gi.GHCi ()+dapVariablesCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= dapVariablesCmd_+ >>= printDAP++-- |+--+dapVariablesCmd_ :: D.VariablesRequestArguments+ -> Gi.GHCi (Either String D.VariablesResponseBody)+dapVariablesCmd_ args = do+ let idx = D.variablesReferenceVariablesRequestArguments args+ vals <- getBindingVariables idx+ return $ Right $ D.VariablesResponseBody $ L.sortBy compName vals+ where+ -- |+ --+ compName :: D.Variable -> D.Variable -> Ordering+ compName a b = compare (D.nameVariable a) (D.nameVariable b)+++-- |+--+getBindingVariables :: Int -> Gi.GHCi [D.Variable]+getBindingVariables idx+ | 1 == idx = getBindingVariablesLocal+ | 2 == idx = getBindingVariablesGlobal+ | otherwise = getBindingVariablesNode idx+++-- |+--+getBindingVariablesLocal :: Gi.GHCi [D.Variable]+getBindingVariablesLocal = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar+ getBindingVariablesRoot bindings+++-- |+--+getBindingVariablesGlobal :: Gi.GHCi [D.Variable]+getBindingVariablesGlobal = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ bindings <- liftIO $ bindingGlobalDAPContext <$> readMVar ctxMVar+ getBindingVariablesRoot bindings+++-- |+--+getBindingVariablesRoot :: [G.TyThing] -> Gi.GHCi [D.Variable]+getBindingVariablesRoot bindings = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ let isInspect = isInspectVariableDAPContext ctx+ mapM (tyThing2Var isInspect) bindings++ +-- |+--+getBindingVariablesNode :: Int -> Gi.GHCi [D.Variable]+getBindingVariablesNode idx = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ case M.lookup idx (variableReferenceMapDAPContext ctx) of+ Just (t, str) -> term2Vars t str+ Nothing -> throwError $ "variable id:" ++ show idx ++ " not found."++ where+ -- |+ --+ term2Vars :: Term -> String -> Gi.GHCi [D.Variable]+ term2Vars (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 (flip term2Var str) $ zip labels subTerms++ term2Vars (Term _ (Left _) _ subTerms) str = do+ let labels = map (\i->"_" ++ show i) [1..(length subTerms)]+ mapM (flip term2Var str) $ zip labels subTerms++ term2Vars t str = do+ dflags <- getDynFlags+ let tstr = showSDoc dflags (ppr t)+ warnL $ "unsupported map term type. " ++ tstr ++ ". idx:" ++ show idx ++ ", name:" ++ str+ return []+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-evaluate+------------------------------------------------------------------------------------------------+-- |+--+dapEvalCmd :: String -> Gi.GHCi ()+dapEvalCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= dapEvalCmd_+ >>= printDAP++-- |+--+dapEvalCmd_ :: D.EvaluateRequestArguments+ -> Gi.GHCi (Either String D.EvaluateResponseBody)+dapEvalCmd_ args = case D.contextEvaluateRequestArguments args of+ Nothing -> runRepl args+ Just "repl" -> runRepl args+ Just "watch" -> runOther args+ Just "hover" -> runOther args+ _ -> runOther args+ where+ -- |+ --+ runRepl :: D.EvaluateRequestArguments -> Gi.GHCi (Either String D.EvaluateResponseBody)+ runRepl args = runStmt $ D.expressionEvaluateRequestArguments args++ -- |+ --+ runStmt :: String -> Gi.GHCi (Either String D.EvaluateResponseBody)+ runStmt "" =+ return $ Right D.defaultEvaluateResponseBody {+ D.resultEvaluateResponseBody = "no input."+ , D.typeEvaluateResponseBody = "no input."+ , D.variablesReferenceEvaluateResponseBody = 0+ }+ runStmt stmt = do+ var <- runStmtVar stmt+ return $ Right D.defaultEvaluateResponseBody {+ D.resultEvaluateResponseBody = D.valueVariable var+ , D.typeEvaluateResponseBody = D.typeVariable var+ , D.variablesReferenceEvaluateResponseBody = D.variablesReferenceVariable var+ }+ + -- |+ --+ runOther :: D.EvaluateRequestArguments -> Gi.GHCi (Either String D.EvaluateResponseBody)+ runOther args = do + let nameStr = D.expressionEvaluateRequestArguments args+ names <- G.parseName nameStr+ var <- names2Var nameStr names+ return $ Right D.defaultEvaluateResponseBody {+ D.resultEvaluateResponseBody = D.valueVariable var+ , D.typeEvaluateResponseBody = D.typeVariable var+ , D.variablesReferenceEvaluateResponseBody = D.variablesReferenceVariable var+ }++------------------------------------------------------------------------------------------------+-- DAP Command :dap-continue+------------------------------------------------------------------------------------------------+-- |+--+dapContinueCmd :: String -> Gi.GHCi ()+dapContinueCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= dapContinueCmd_+ >>= printDAP++-- |+--+dapContinueCmd_ :: D.ContinueRequestArguments+ -> Gi.GHCi (Either String D.StoppedEventBody)+dapContinueCmd_ args = do+ seb <- case D.exprContinueRequestArguments args of+ Just exp -> startTrace exp+ Nothing -> continue+ + return $ Right seb++ where+ -- |+ --+ startTrace :: String -> Gi.GHCi D.StoppedEventBody+ startTrace expr = do+ clearContinueExecResult++ -- ghci maybe throw error cause of force inspecting variable.+ gcatch (Gi.traceCmd expr) unexpectErrHdl++ handleResult+ + -- |+ --+ continue :: Gi.GHCi D.StoppedEventBody+ continue = startTrace ""++ -- |+ --+ handleResult :: Gi.GHCi D.StoppedEventBody+ handleResult = hasBreaked >>= \case+ False -> genStoppedEventBody+ True -> isBreakthrough >>= \case+ False -> genStoppedEventBody+ True -> continue++ -- |+ --+ hasBreaked :: Gi.GHCi Bool+ hasBreaked = getContinueExecResult >>= \case+ Just G.ExecBreak {G.breakInfo = Just _} -> return True+ _ -> return False++ -- |+ --+ isBreakthrough :: Gi.GHCi Bool+ isBreakthrough = G.getResumeContext >>= \case+ [] -> warnL "invalid resume state. resume not found."+ >> return False+ (r:_) -> pure (G.resumeBreakInfo r)+ >>= Gi.toBreakIdAndLocation+ >>= withBreakInfo++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withBreakInfo :: Maybe (Int, Gi.BreakLocation) -> Gi.GHCi Bool+ withBreakInfo Nothing = do+ warnL "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+ warnL $ "invalid break no. " ++ show no+ return False++ -- |+ --+ findSrcBP :: Int -> Gi.GHCi (Maybe SourceBreakpointInfo)+ findSrcBP no = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ srcBPs <- liftIO $ srcBPsDAPContext <$> readMVar ctxMVar+ return $ M.lookup no srcBPs++ -- |+ --+ findFuncBP :: Int -> Gi.GHCi (Maybe (D.FunctionBreakpoint, Int))+ findFuncBP no = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ funcBPs <- liftIO $ funcBPsDAPContext <$> readMVar ctxMVar+ return $ M.lookup no funcBPs++ -- |+ -- @return+ -- True -> thruough+ -- False -> break+ --+ withSrcBP :: Int -> SourceBreakpointInfo -> Gi.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 :: Int -> (D.FunctionBreakpoint, Int) -> Gi.GHCi Bool+ 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 -> Gi.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++ updateSrcBreakCounter no bpInfo{hitCntSourceBreakpointInfo = newCnt}++ var <- runStmtVar stmt+ when ("Bool" /= D.typeVariable var) $ do+ warnL $ "hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show var+ debugL $ "hit condition statement result. " ++ stmt ++ " -> " ++ show var+ return $ Just ("False" == D.valueVariable var)+++ -- |+ --+ updateSrcBreakCounter :: Int -> SourceBreakpointInfo -> Gi.GHCi ()+ updateSrcBreakCounter no bpInfo = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let cur = srcBPsDAPContext ctx+ new = M.insert no bpInfo cur+ liftIO $ putMVar ctxMVar ctx{srcBPsDAPContext = new}+++ -- |+ --+ funcBreakthroughCounterHandler :: Int -> (D.FunctionBreakpoint, Int) -> Gi.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++ updateFuncBreakCounter no (fst info, newCnt)++ var <- runStmtVar stmt+ when ("Bool" /= D.typeVariable var) $ do+ warnL $ "hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show var+ debugL $ "hit condition statement result. " ++ stmt ++ " -> " ++ show var+ return $ Just ("False" == D.valueVariable var)+++ -- |+ --+ updateFuncBreakCounter :: Int -> (D.FunctionBreakpoint, Int) -> Gi.GHCi ()+ updateFuncBreakCounter no bpInfo = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let cur = funcBPsDAPContext ctx+ new = M.insert no bpInfo cur+ liftIO $ putMVar ctxMVar ctx{funcBPsDAPContext = new}+++ -- |+ -- @return+ -- True -> breakthrough+ -- False -> break+ --+ breakthroughCondtionHandler :: Int -> Maybe String -> Gi.GHCi (Maybe Bool)+ breakthroughCondtionHandler _ Nothing = return Nothing+ breakthroughCondtionHandler no (Just stmt) = do+ var <- runStmtVar stmt+ when ("Bool" /= D.typeVariable var) $ do+ warnL $ "condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show var+ return $ Just ("False" == D.valueVariable var)+ ++ -- |+ -- @return+ -- must be True -> breakthrough+ -- + logPointHandler :: Int -> Maybe String -> Gi.GHCi (Maybe Bool)+ logPointHandler _ Nothing = return Nothing+ logPointHandler _ (Just stmt) = do+ var <- runStmtVar stmt+ let msg = D.valueVariable var ++ "\n"+ body = D.defaultOutputEventBody { D.outputOutputEventBody = msg+ , D.categoryOutputEventBody = "console"}++ printOutputEventDAP (Right body)+ return $ Just True+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-next+------------------------------------------------------------------------------------------------+-- |+--+nextCmd :: String -> Gi.GHCi ()+nextCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= nextCmd_+ >>= printDAP++-- |+-- +nextCmd_ :: D.NextRequestArguments+ -> Gi.GHCi (Either String D.StoppedEventBody)+nextCmd_ _ = do+ clearContinueExecResult++ -- ghci maybe throw error cause of force inspecting variable.+ gcatch (Gi.stepLocalCmd "") unexpectErrHdl++ Right <$> genStoppedEventBody+++------------------------------------------------------------------------------------------------+-- DAP Command :dap-step-in+------------------------------------------------------------------------------------------------+-- |+--+stepInCmd :: String -> Gi.GHCi ()+stepInCmd argsStr = flip gcatch errHdl $ do+ decodeDAP argsStr+ >>= stepInCmd_+ >>= printDAP++-- |+-- +stepInCmd_ :: D.StepInRequestArguments+ -> Gi.GHCi (Either String D.StoppedEventBody)+stepInCmd_ _ = do+ clearContinueExecResult++ -- ghci maybe throw error cause of force inspecting variable.+ gcatch (Gi.stepCmd "") unexpectErrHdl++ Right <$> genStoppedEventBody+
app/GHCi/DAP/Constant.hs view
@@ -9,11 +9,6 @@ -- | ---_DAP_CMD_END :: String-_DAP_CMD_END = "<<DAP_CMD_END>>"---- |--- _DAP_HEADER_OUTPUT_EVENT :: String _DAP_HEADER_OUTPUT_EVENT = "<<DAP_OUTPUT_EVENT>>"
app/GHCi/DAP/Type.hs view
@@ -1,6 +1,6 @@ module GHCi.DAP.Type where -import qualified GHC+import qualified GHC as G import RtClosureInspect import qualified Data.Map as M@@ -24,8 +24,20 @@ -- type MVarDAPContext = MVar DAPContext + -- | --+data LogLevel = ErrorLogLevel | WarnLogLevel | InfoLogLevel | DebugLogLevel+ deriving (Eq, Ord)++instance Show LogLevel where+ show ErrorLogLevel = "[DAP][ERROR]"+ show WarnLogLevel = "[DAP][WARN]"+ show InfoLogLevel = "[DAP][INFO]"+ show DebugLogLevel = "[DAP][DEBUG]"++-- |+-- data SourceBreakpointInfo = SourceBreakpointInfo { modNameSourceBreakpointInfo :: ModuleName , srcBPSourceBreakpointInfo :: D.SourceBreakpoint@@ -37,14 +49,17 @@ -- 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]+ , bindingDAPContext :: [G.TyThing]+ , bindingGlobalDAPContext :: [G.TyThing]+ , frameIdDAPContext :: Int+ , srcBPsDAPContext :: M.Map Int SourceBreakpointInfo+ , funcBPsDAPContext :: M.Map Int (D.FunctionBreakpoint, Int)+ , runStmtDeclExceptionDAPContext :: Maybe SourceError+ , logLevelDAPContext :: LogLevel+ , stackTraceResultDAPContext :: Maybe (G.Resume, [G.History])+ , bindingNamesDAPContext :: [G.Name]+ , isInspectVariableDAPContext :: Bool+ , continueExecResultDAPContext :: Maybe G.ExecResult } @@ -58,9 +73,12 @@ , frameIdDAPContext = 0 , srcBPsDAPContext = M.fromList [] , funcBPsDAPContext = M.fromList []- , traceCmdExecResultDAPContext = []- , doContinueExecResultDAPContext = []- , runStmtDeclExceptionDAPContext = []+ , runStmtDeclExceptionDAPContext = Nothing+ , logLevelDAPContext = InfoLogLevel+ , stackTraceResultDAPContext = Nothing+ , bindingNamesDAPContext = []+ , isInspectVariableDAPContext = True+ , continueExecResultDAPContext = Nothing }
+ app/GHCi/DAP/UI.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE LambdaCase #-}++module GHCi.DAP.UI where++import qualified GHC as G+import qualified GHCi.UI.Monad as Gi hiding (runStmt)+import Control.Concurrent+import Control.Monad.IO.Class+import InteractiveEval++import GHCi.DAP.Type++-- | +--+setStackTraceResult :: G.Resume -> [G.History] -> Gi.GHCi ()+setStackTraceResult r hs = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {stackTraceResultDAPContext = Just (r, hs)}+++-- | +--+setBindingNames :: [G.Name] -> Gi.GHCi ()+setBindingNames names = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {bindingNamesDAPContext = names}++{-+-- |+--+saveTraceCmdExecResult :: Maybe ExecResult -> Gi.GHCi (Maybe ExecResult)+saveTraceCmdExecResult res = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState ++ ctx <- liftIO $ takeMVar ctxMVar+ let cur = traceCmdExecResultDAPContext ctx++ liftIO $ putMVar ctxMVar ctx{traceCmdExecResultDAPContext = res : cur}++ return res+++-- |+--+saveDoContinueExecResult :: ExecResult -> Gi.GHCi ExecResult+saveDoContinueExecResult res = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState ++ ctx <- liftIO $ takeMVar ctxMVar+ let cur = doContinueExecResultDAPContext ctx++ liftIO $ putMVar ctxMVar ctx{doContinueExecResultDAPContext = res : cur}++ return res+-}++-- |+--+setContinueExecResult :: Maybe ExecResult -> Gi.GHCi (Maybe ExecResult)+setContinueExecResult res = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState + ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx{continueExecResultDAPContext = res}+ return res+
app/GHCi/DAP/Utility.hs view
@@ -2,26 +2,35 @@ module GHCi.DAP.Utility where -import qualified GHC-import qualified GHCi.UI.Monad as G+import qualified GHC as G+import qualified Module as G+import qualified GHCi.UI.Monad as Gi hiding (runStmt)+import qualified GHCi.UI as Gi 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 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 Control.Monad+import FastString+import HscTypes+import InteractiveEvalTypes+import RtClosureInspect+import PprTyThing+import DynFlags+import DataCon+import Debugger+import qualified Data.Map as M import GHCi.DAP.Constant import GHCi.DAP.Type- import qualified Haskell.DAP as D -- |@@ -82,6 +91,18 @@ -- |+--+takeModPath :: ModSummary -> (String, FilePath)+takeModPath ms = (G.moduleNameString (G.ms_mod_name ms), G.ms_hspp_file ms)+++-- |+--+isPathMatch :: FilePath -> (String, FilePath) -> Bool+isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)+++-- | -- to lowercase Windows drive letter -- drive2lower :: FilePath -> FilePath@@ -119,7 +140,7 @@ -- | ---printDAP :: Show a => a -> G.GHCi ()+printDAP :: Show a => a -> Gi.GHCi () printDAP dat = do let outStr = _DAP_HEADER ++ showDAP dat @@ -127,7 +148,7 @@ -- | ---printOutputEventDAP :: (Either String D.OutputEventBody) -> G.GHCi ()+printOutputEventDAP :: (Either String D.OutputEventBody) -> Gi.GHCi () printOutputEventDAP dat = do let outStr = _DAP_HEADER_OUTPUT_EVENT ++ showDAP dat @@ -136,37 +157,287 @@ -- | ---clearTmpDAPContext :: G.GHCi ()-clearTmpDAPContext = do- mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState +decodeDAP :: Read a => String -> Gi.GHCi a+decodeDAP argsStr = liftEither (readDAP argsStr) - ctx <- liftIO $ takeMVar mvarCtx- liftIO $ putMVar mvarCtx ctx{- traceCmdExecResultDAPContext = []- , doContinueExecResultDAPContext = []- , runStmtDeclExceptionDAPContext = []- }+-- |+--+liftEither :: Show a => Either a b -> Gi.GHCi b+liftEither (Left e) = liftIO $ Exception.throwIO $ userError $ show e+liftEither (Right x) = return x +-- |+--+errHdl :: SomeException -> Gi.GHCi ()+errHdl e = do+ let msg = displayException e+ res = Left msg :: Either String ()+ printDAP res -- | ---isExceptionResume :: GHC.Resume -> Bool-isExceptionResume (GHC.Resume{GHC.resumeBreakInfo = a}) = isNothing a+unexpectErrHdl :: SomeException -> Gi.GHCi ()+unexpectErrHdl e = do+ warnL $ "ghci says,\n" ++ show e -- | ---parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name]-parseNameErrorHandler e = liftIO $ print e >> return []+throwError :: String -> Gi.GHCi a+throwError = liftIO . throwIO . userError -- | ---showTermErrorHandler :: SomeException -> G.GHCi SDoc-showTermErrorHandler e = return $ text $ show e+isExceptionResume :: G.Resume -> Bool+isExceptionResume (G.Resume{G.resumeBreakInfo = a}) = isNothing a +-------------------------------------------------------------------- -- | --+errorL :: String -> Gi.GHCi ()+errorL msg = logging ErrorLogLevel msg++-- |+--+warnL :: String -> Gi.GHCi ()+warnL msg = logging WarnLogLevel msg++-- |+--+infoL :: String -> Gi.GHCi ()+infoL msg = logging InfoLogLevel msg++-- |+--+debugL :: String -> Gi.GHCi ()+debugL msg = logging DebugLogLevel msg++-- |+--+logging :: LogLevel -> String -> Gi.GHCi ()+logging l msg = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ lv <- liftIO $ logLevelDAPContext <$> readMVar ctxMVar+ when (lv >= l) $ do+ liftIO $ putStrLn $ show l ++ msg++--------------------------------------------------------------------+++-- |+--+delBreakpoint :: Int -> Gi.GHCi Bool+delBreakpoint bpNoStr = do+ curSt <- Gi.getGHCiState+ let curCount = Gi.break_ctr curSt++ Gi.deleteCmd (show bpNoStr)+ + newSt <- Gi.getGHCiState+ let newCount = Gi.break_ctr newSt++ return (newCount == curCount - 1)+++-- |+--+addBreakpoint :: String -> Gi.GHCi D.Breakpoint+addBreakpoint argStr = do+ curSt <- Gi.getGHCiState+ let curCount = Gi.break_ctr curSt++ Gi.breakCmd argStr+ + newSt <- Gi.getGHCiState+ let newCount = Gi.break_ctr newSt+ isAdded = (newCount == curCount + 1)+ locMay = if isAdded then Just (head (Gi.breaks newSt)) else Nothing+ + withBreakLoc locMay++ where+ withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (Gi.breakLoc bpLoc)+ withBreakLoc Nothing = return D.defaultBreakpoint {+ D.verifiedBreakpoint = False+ , D.messageBreakpoint = "set breakpoint seems to be failed."+ }++ withSrcSpan no bpLoc (G.RealSrcSpan dat) = return+ D.defaultBreakpoint {+ D.idBreakpoint = Just no+ , D.verifiedBreakpoint = True+ , D.sourceBreakpoint = D.defaultSource {+ D.nameSource = (Just . G.moduleNameString . G.moduleName . Gi.breakModule) bpLoc+ , D.pathSource = (unpackFS . G.srcSpanFile) dat+ , D.sourceReferenceSource = Nothing+ , D.origineSource = Nothing+ }+ , D.lineBreakpoint = G.srcSpanStartLine dat+ , D.columnBreakpoint = G.srcSpanStartCol dat+ , D.endLineBreakpoint = G.srcSpanEndLine dat+ , D.endColumnBreakpoint = G.srcSpanEndCol dat+ }++ withSrcSpan _ _ (G.UnhelpfulSpan _) = return D.defaultBreakpoint {+ D.verifiedBreakpoint = False+ , D.messageBreakpoint = "UnhelpfulSpan breakpoint."+ }+++--------------------------------------------------------------------++-- |+--+genStoppedEventBody :: Gi.GHCi D.StoppedEventBody+genStoppedEventBody = getContinueExecResult >>= \case+ Nothing -> throwError "ExecResult not found."+ Just er -> execResult2StoppedEventBody er+++-- |+--+execResult2StoppedEventBody :: G.ExecResult -> Gi.GHCi D.StoppedEventBody+execResult2StoppedEventBody (G.ExecComplete { G.execResult = Right _ }) = do+ return D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "complete"+ }+ +execResult2StoppedEventBody (G.ExecComplete { G.execResult = Left (SomeException e)}) = do+ return D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "complete"+ , D.descriptionStoppedEventBody = show e+ , D.textStoppedEventBody = show e+ }++execResult2StoppedEventBody (G.ExecBreak{G.breakInfo = Just (BreakInfo _ _)}) = do+ return D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "breakpoint"+ }++execResult2StoppedEventBody (G.ExecBreak{G.breakInfo = Nothing}) = do+ -- have to :force _exception first.+ -- then can show it.+ debugL "stopped by exception"+ gcatch (Gi.forceCmd "_exception") unexpectErrHdl++ let stmt = "show _exception"+ var <- runStmtVar stmt++ return D.defaultStoppedEventBody {+ D.reasonStoppedEventBody = "exception"+ , D.descriptionStoppedEventBody = D.valueVariable var+ , D.textStoppedEventBody = D.valueVariable var+ }+++-- |+--+getNextIdx :: Term -> String -> Gi.GHCi Int+getNextIdx 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 = addTerm2VariableReferenceMap t str++getNextIdx t str = addTerm2VariableReferenceMap t str+++-- |+--+runStmtVar :: String -> Gi.GHCi D.Variable+runStmtVar stmt = do+ clearRunStmtDeclException++ Gi.runStmt stmt G.RunToCompletion >>= \case+ Nothing -> getRunStmtSourceError >>= throwError+ Just (G.ExecBreak _ Nothing) -> throwError $ "unexpected break occured while evaluating stmt:" ++ stmt+ Just (G.ExecBreak _ (Just (BreakInfo (G.Module _ modName) idx))) -> do+ let modStr = G.moduleNameString modName+ let msg = "unexpected break occured. breakNo:" ++ show idx+ ++ " in " ++ modStr ++ " while evaluating stmt:" ++ stmt+ throwError msg+ Just (G.ExecComplete (Left msg) _) -> throwError $ "runStmt error. " ++ show msg+ Just (G.ExecComplete (Right names) _) -> names2Var stmt names+ +++-- |+--+names2Var :: String -> [G.Name] -> Gi.GHCi D.Variable+names2Var key names+ | 0 == length names = throwError $ "Not in scope. " ++ key+ | 1 == length names = name2Var key (head names)+ | otherwise = throwError $ "Ambiguous name. " ++ key+++-- |+--+name2Var :: String -> G.Name -> Gi.GHCi D.Variable+name2Var key n = G.lookupName n >>= \case+ Nothing -> throwError $ "TyThing not found. " ++ key+ Just ty -> tyThing2Var True ty++--------------------------------------------------------------------------++-- |+-- TyThings https://hackage.haskell.org/package/ghc-8.2.1/docs/HscTypes.html#t:TyThing+--+tyThing2Var :: Bool -> G.TyThing -> Gi.GHCi D.Variable+tyThing2Var _ t@(AConLike c) = defTy2Var t c+tyThing2Var _ t@(ATyCon c) = defTy2Var t c+tyThing2Var _ t@(ACoAxiom c) = defTy2Var t c+tyThing2Var isInspect (AnId i) = inspectGID isInspect i+++-- |+--+defTy2Var :: (Outputable a, Outputable b)+ => a -> b -> Gi.GHCi D.Variable+defTy2Var n t = do+ dflags <- getDynFlags+ let name = showSDoc dflags (ppr n)+ typ = showSDoc dflags (ppr t)+ return D.defaultVariable {+ D.nameVariable = name+ , D.typeVariable = typ+ , D.valueVariable = "<define>"+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }++-- |+--+inspectGID :: Bool -> G.Id -> Gi.GHCi D.Variable+inspectGID False i = gid2Var i+inspectGID True i = do+ dflags <- getDynFlags+ case showSDoc dflags (ppr i) of+ "_result" -> gid2Var i+ _ -> G.obtainTermFromId _BINDING_INSPECT_DEPTH True i >>= term2VarById i++-- |+--+gid2Var :: G.Id -> Gi.GHCi D.Variable+gid2Var i = do+ dflags <- getDynFlags+ idSDoc <- pprTypeAndContents i++ let (nameStr, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc)++ return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = valStr+ , D.evaluateNameVariable = Just nameStr+ , D.variablesReferenceVariable = 0+ }++-- |+-- getNameTypeValue :: String -> (String, String, String) getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr) where@@ -174,16 +445,150 @@ typeStr = unwords $ takeWhile ((/=)"=") $ tail $ tail $ words str valueStr = unwords $ tail $ dropWhile ((/=)"=") $ words str + -- | ---getRunStmtSourceError :: G.GHCi String+term2VarById :: G.Id -> Term -> Gi.GHCi D.Variable+term2VarById i t@(Term _ _ _ _) = do+ dflags <- getDynFlags+ let nameStr = showSDoc dflags (ppr i)+ evalStr = ""+ term2Var (nameStr, t) evalStr+term2VarById i _ = gid2Var i+++-- |+-- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html+--+term2Var :: (String, Term) -> String -> Gi.GHCi D.Variable+term2Var (label, t@(Term ty _ _ _)) evalStr = do+ dflags <- getDynFlags+ termSDoc <- showTerm t+ let nameStr = label+ typeStr = showSDoc dflags (pprTypeForUser ty)+ valStr = showSDoc dflags termSDoc+ evlStr = if null evalStr then nameStr else evalStr++ nextIdx <- getNextIdx t nameStr+ typVal <- if 0 == nextIdx then return valStr+ else getDataConstructor t valStr++ return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = typVal+ , D.evaluateNameVariable = Just evlStr+ , D.variablesReferenceVariable = nextIdx+ }++term2Var (label, t) _ = do+ dflags <- getDynFlags+ termSDoc <- showTerm t+ let nameStr = label+ typeStr = showSDoc dflags termSDoc+ valStr = showSDoc dflags termSDoc++ return D.defaultVariable {+ D.nameVariable = nameStr+ , D.typeVariable = typeStr+ , D.valueVariable = valStr+ , D.evaluateNameVariable = Nothing+ , D.variablesReferenceVariable = 0+ }+++-- |+--+getDataConstructor :: Term -> String -> Gi.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 t defVal = do+ dflags <- getDynFlags+ termSDoc <- showTerm t+ let tstr = showSDoc dflags termSDoc+ warnL $ "can not get constructer type. " ++ tstr+ return defVal+++--------------------------------------------------------------------------+-- | Accessor to DAPContext+--------------------------------------------------------------------------++-- | +--+clearBindingNames :: Gi.GHCi ()+clearBindingNames = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {bindingNamesDAPContext = []}++-- | +--+getBindingNames :: Gi.GHCi [G.Name]+getBindingNames = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ return $ bindingNamesDAPContext ctx+++-- | +--+clearContinueExecResult :: Gi.GHCi ()+clearContinueExecResult = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {continueExecResultDAPContext = Nothing}++-- | +--+getContinueExecResult :: Gi.GHCi (Maybe G.ExecResult)+getContinueExecResult = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ return $ continueExecResultDAPContext ctx+++-- | +--+clearRunStmtDeclException :: Gi.GHCi ()+clearRunStmtDeclException = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {runStmtDeclExceptionDAPContext = Nothing}++-- | +--+getRunStmtDeclException :: Gi.GHCi (Maybe SourceError)+getRunStmtDeclException = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ readMVar ctxMVar+ return $ runStmtDeclExceptionDAPContext ctx+++-- |+--+getRunStmtSourceError :: Gi.GHCi String getRunStmtSourceError = do- mvarCtx <- G.dapContextGHCiState <$> G.getGHCiState + err <- getRunStmtDeclException+ let msg = "[DAP][ERROR] error occurred while runStmt. " ++ show err - ctx <- liftIO $ readMVar mvarCtx- let errs = runStmtDeclExceptionDAPContext ctx- msgs = "[DAP][ERROR] error occurred while runStmt." - : map show errs+ return msg - return $ L.intercalate "\n" msgs- ++-- |+--+addTerm2VariableReferenceMap :: Term -> String -> Gi.GHCi Int+addTerm2VariableReferenceMap t str = do+ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ let curMap = variableReferenceMapDAPContext ctx+ nextId = (M.size curMap) + 10++ liftIO $ putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap}++ return nextId
app/Main.hs view
@@ -23,7 +23,7 @@ let ghciSettings = G.defaultGhciSettings mvarCtx defaultCommands = G.availableCommands ghciSettings- withDapCommands = defaultCommands ++ (dapCommands mvarCtx)+ withDapCommands = defaultCommands ++ dapCommands G.ghcMain ghciSettings {G.availableCommands = withDapCommands}
ghci-dap.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 797b27c7333c5791aa0c768dce9f0f4a0a61f71fbb0221d0aaf8db77843a47b3+-- hash: e58fcf2f7d23661dd71ad8f240a0a3e9346a5f824c56af89f081468d12f6fcf7 name: ghci-dap-version: 0.0.11.0+version: 0.0.12.0 synopsis: ghci-dap is a GHCi having DAP interface. description: Please see README.md category: Development@@ -24,7 +24,6 @@ Changelog.md src-c-8.4/HsVersions.h src-c-8.4/PosixSource.h- src-c-8.6/HsVersions.h src-c-8.6/PosixSource.h executable ghci-dap@@ -33,6 +32,7 @@ GHCi.DAP.Command GHCi.DAP.Constant GHCi.DAP.Type+ GHCi.DAP.UI GHCi.DAP.Utility Paths_ghci_dap hs-source-dirs:
src-c-8.4/HsVersions.h view
@@ -13,13 +13,13 @@ #define COMPILING_GHC 1 /* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */--- #include "ghc_boot_platform.h"+/* #include "ghc_boot_platform.h" DAP Modified */ /* 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"+/* #include "../includes/ghcautoconf.h" DAP Modified */ #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \
src-c-8.4/hschooks.c view
@@ -4,7 +4,7 @@ in instead of the defaults. */ -#include "PosixSource.h"+#include "PosixSource.h" /* DAP modified */ /* * This should be linked against Rts.h from the compiler which is compiling us.@@ -60,7 +60,7 @@ (size_t) stack_size); } -/*+/* DAP modified int main (int argc, char *argv[]) { RtsConfig conf = defaultRtsConfig;
− src-c-8.6/HsVersions.h
@@ -1,65 +0,0 @@-#pragma once--#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 SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobal (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobalM (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#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 () }
src-c-8.6/hschooks.c view
@@ -4,7 +4,7 @@ in instead of the defaults. */ -#include "PosixSource.h"+#include "PosixSource.h" /* DAP modified */ /* * This should be linked against Rts.h from the compiler which is compiling us.@@ -60,7 +60,7 @@ (size_t) stack_size); } -/*+/* DAP modified int main (int argc, char *argv[]) { RtsConfig conf = defaultRtsConfig;