diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,8 +7,7 @@ ![101_deploy.png](https://raw.githubusercontent.com/phoityne/haskell-debug-adapter/master/docs/design/101_deploy.png) 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 diff --git a/app-ghc-8.4/GHCMain.hs b/app-ghc-8.4/GHCMain.hs --- a/app-ghc-8.4/GHCMain.hs +++ b/app-ghc-8.4/GHCMain.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/app-ghc-8.4/GHCi/UI.hs b/app-ghc-8.4/GHCi/UI.hs --- a/app-ghc-8.4/GHCi/UI.hs +++ b/app-ghc-8.4/GHCi/UI.hs @@ -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 "" 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 " 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 diff --git a/app-ghc-8.4/GHCi/UI/Monad.hs b/app-ghc-8.4/GHCi/UI/Monad.hs --- a/app-ghc-8.4/GHCi/UI/Monad.hs +++ b/app-ghc-8.4/GHCi/UI/Monad.hs @@ -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 diff --git a/app-ghc-8.6/GHCMain.hs b/app-ghc-8.6/GHCMain.hs --- a/app-ghc-8.6/GHCMain.hs +++ b/app-ghc-8.6/GHCMain.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/app-ghc-8.6/GHCi/UI.hs b/app-ghc-8.6/GHCi/UI.hs --- a/app-ghc-8.6/GHCi/UI.hs +++ b/app-ghc-8.6/GHCi/UI.hs @@ -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 "" 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 " 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 - diff --git a/app-ghc-8.6/GHCi/UI/Monad.hs b/app-ghc-8.6/GHCi/UI/Monad.hs --- a/app-ghc-8.6/GHCi/UI/Monad.hs +++ b/app-ghc-8.6/GHCi/UI/Monad.hs @@ -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 diff --git a/app/GHCi/DAP/Command.hs b/app/GHCi/DAP/Command.hs --- a/app/GHCi/DAP/Command.hs +++ b/app/GHCi/DAP/Command.hs @@ -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 = "" - , 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 = "" - , 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 = "" - -} - - 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 $ " 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 $ " " ++ 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 $ " 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 $ " " ++ 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 + diff --git a/app/GHCi/DAP/Constant.hs b/app/GHCi/DAP/Constant.hs --- a/app/GHCi/DAP/Constant.hs +++ b/app/GHCi/DAP/Constant.hs @@ -9,11 +9,6 @@ -- | -- -_DAP_CMD_END :: String -_DAP_CMD_END = "<>" - --- | --- _DAP_HEADER_OUTPUT_EVENT :: String _DAP_HEADER_OUTPUT_EVENT = "<>" diff --git a/app/GHCi/DAP/Type.hs b/app/GHCi/DAP/Type.hs --- a/app/GHCi/DAP/Type.hs +++ b/app/GHCi/DAP/Type.hs @@ -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 } diff --git a/app/GHCi/DAP/UI.hs b/app/GHCi/DAP/UI.hs new file mode 100644 --- /dev/null +++ b/app/GHCi/DAP/UI.hs @@ -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 + diff --git a/app/GHCi/DAP/Utility.hs b/app/GHCi/DAP/Utility.hs --- a/app/GHCi/DAP/Utility.hs +++ b/app/GHCi/DAP/Utility.hs @@ -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 = "" + , 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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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} diff --git a/ghci-dap.cabal b/ghci-dap.cabal --- a/ghci-dap.cabal +++ b/ghci-dap.cabal @@ -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: diff --git a/src-c-8.4/HsVersions.h b/src-c-8.4/HsVersions.h --- a/src-c-8.4/HsVersions.h +++ b/src-c-8.4/HsVersions.h @@ -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 #-}; \ diff --git a/src-c-8.4/hschooks.c b/src-c-8.4/hschooks.c --- a/src-c-8.4/hschooks.c +++ b/src-c-8.4/hschooks.c @@ -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; diff --git a/src-c-8.6/HsVersions.h b/src-c-8.6/HsVersions.h deleted file mode 100644 --- a/src-c-8.6/HsVersions.h +++ /dev/null @@ -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 () } diff --git a/src-c-8.6/hschooks.c b/src-c-8.6/hschooks.c --- a/src-c-8.6/hschooks.c +++ b/src-c-8.6/hschooks.c @@ -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;