diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,9 @@ +20180430 haskell-dap-0.0.4.0 + + * [ADD] next, stepIn, setFunctionBreakpoint commands. + + 20180225 haskell-dap-0.0.3.0 * [ADD] setBreakpoint, continue, scopes, stackTrace, evaluate commands. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,8 +7,8 @@ ## Information -* [2018/02/25] Release haskel-dap-0.0.3.0. - * [ADD] setBreakpoint, continue, scopes, stackTrace, evaluate commands. +* [2018/04/30] Release haskel-dap-0.0.4.0. + * [ADD] next, stepIn, setFunctionBreakpoint commands. ## Limitation @@ -51,4 +51,10 @@ ![if_data.png](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/if_data.png) +## Sequences +### Overview. +![seq1.png](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/seq1.png) + +### Debugging details. +![seq2.png](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/seq2.png) diff --git a/app-ghc-8.0/GHCi/UI.hs b/app-ghc-8.0/GHCi/UI.hs --- a/app-ghc-8.0/GHCi/UI.hs +++ b/app-ghc-8.0/GHCi/UI.hs @@ -31,7 +31,9 @@ getLoadedModules, breakCmd, deleteCmd, - traceCmd + traceCmd, + stepCmd, + stepLocalCmd ) where #include "HsVersions.h" diff --git a/app-ghc-8.2/GHCi/UI.hs b/app-ghc-8.2/GHCi/UI.hs --- a/app-ghc-8.2/GHCi/UI.hs +++ b/app-ghc-8.2/GHCi/UI.hs @@ -31,7 +31,9 @@ getLoadedModules, breakCmd, deleteCmd, - traceCmd + traceCmd, + stepCmd, + stepLocalCmd ) where #include "HsVersions.h" diff --git a/app/Haskell/DAP/GHCi/Command.hs b/app/Haskell/DAP/GHCi/Command.hs --- a/app/Haskell/DAP/GHCi/Command.hs +++ b/app/Haskell/DAP/GHCi/Command.hs @@ -12,7 +12,6 @@ import DataCon import DynFlags import RtClosureInspect -import Data.List import qualified GHCi.UI as G import qualified GHCi.UI.Monad as G @@ -41,9 +40,13 @@ ("dap-echo", dapEcho, noCompletion) --, ("dap-force", dapForceCommand ctx, noCompletion) , ("dap-scopes", dapScopesCommand ctx, noCompletion) - , ("dap-history", dapHistoryCommand ctx, noCompletion) + --, ("dap-history", dapHistoryCommand ctx, noCompletion) , ("dap-set-breakpoints", dapSetBreakpointsCommand ctx, noCompletion) + , ("dap-set-function-breakpoints" + , dapSetFunctionBreakpointsCommand ctx, noCompletion) , ("dap-continue", dapContinueCommand ctx, noCompletion) + , ("dap-next", dapNextCommand ctx, noCompletion) + , ("dap-step-in", dapStepInCommand ctx, noCompletion) , ("dap-stacktrace", dapStackTraceCommand ctx, noCompletion) , ("dap-variables", dapVariablesCommand ctx, noCompletion) , ("dap-evaluate", dapEvaluateCommand ctx, noCompletion) @@ -74,6 +77,7 @@ -- | -- +{- dapHistoryCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool dapHistoryCommand ctxMVar _ = do ctx <- liftIO $ takeMVar ctxMVar @@ -84,7 +88,7 @@ liftIO $ putStrLn outStr return False - +-} ------------------------------------------------------------------------------------------------ -- DAP Command :dap-scopes @@ -192,49 +196,198 @@ return False where + -- | + -- withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = do - let srcBPs = D.sourceSetBreakpointsArguments args - srcPath = D.pathSource srcBPs - delSrcBreakpintsInFile ctxMVar srcPath + withArgs (Right args) = deleteBreakpoints args + >> addBreakpoints args + -- | + -- + deleteBreakpoints args = do + let srcInfo = D.sourceSetBreakpointsArguments args + srcPath = D.pathSource srcInfo + + bps <- liftIO $ getDelBPs (nzPath srcPath) + + liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] delete src bps " ++ show bps + + mapM_ (lift.delBreakpoint.show) bps + + -- | + -- + getDelBPs srcPath = do + ctx <- takeMVar ctxMVar + + let bpNOs = M.keys $ M.filter ((==) srcPath) $ srcBPsDAPContext ctx + newSrcBPs = M.filter ((/=) srcPath) $ srcBPsDAPContext ctx + + putMVar ctxMVar $ ctx {srcBPsDAPContext = newSrcBPs} + + return bpNOs + + -- | + -- + addBreakpoints args = do + let srcInfo = D.sourceSetBreakpointsArguments args + srcPath = D.pathSource srcInfo + modSums <- G.getLoadedModules let modPaths = map takeModPath modSums case filter (isPathMatch srcPath) modPaths of ((m, p):[]) -> do - liftIO $ putStrLn $ "[DAP][INFO][dapBreakCommand] " ++ p ++ " -> " ++ m + liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m withMod args m _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths + -- | + -- takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms) + -- | + -- isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p) + -- | + -- withMod args mod = do let srcBPs = D.breakpointsSetBreakpointsArguments args - addBps <- mapM (go mod) srcBPs - liftIO $ mapM_ updateBreakpointTypeMap addBps + addBps <- mapM (addBP mod) srcBPs + liftIO $ updateBpCtx addBps + return $ Right $ D.SetBreakpointsResponseBody addBps - go mod srcBP = do - curSt <- G.getGHCiState - let curCount = G.break_ctr curSt - lineNo = show $ D.lineSourceBreakpoint srcBP + -- | + -- + addBP mod srcBP = do + let lineNo = show $ D.lineSourceBreakpoint srcBP colNo = maybe "" show $ D.columnSourceBreakpoint srcBP argStr = mod ++ " " ++ lineNo ++ " " ++ colNo - lift $ G.breakCmd argStr - - newSt <- G.getGHCiState - let newCount = G.break_ctr newSt - isAdded = (newCount == curCount + 1) - locMay = if isAdded then Just (head (G.breaks newSt)) else Nothing + lift $ addBreakpoint argStr + + -- | + -- + updateBpCtx bps = do + ctx <- takeMVar ctxMVar + let cur = srcBPsDAPContext ctx + new = M.fromList $ foldr getBpNoAndPath [] bps + putMVar ctxMVar $ ctx{srcBPsDAPContext = (M.union cur new)} + + -- | + -- + getBpNoAndPath bp acc = case D.idBreakpoint bp of + Nothing -> acc + Just no -> (no, (nzPath . D.pathSource . D.sourceBreakpoint) (bp)) : acc + + +------------------------------------------------------------------------------------------------ +-- DAP Command :dap-set-function-breakpoints +------------------------------------------------------------------------------------------------ + +-- | +-- +dapSetFunctionBreakpointsCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool +dapSetFunctionBreakpointsCommand ctxMVar argsStr = do + res <- withArgs (readDAP argsStr) + lift $ printDAP res + return False + + where + withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr + withArgs (Right args) = deleteBreakpoints + >> addBreakpoints args - withBreakLoc locMay + -- | + -- + deleteBreakpoints = do + bps <- liftIO $ getDelBPs + + liftIO $ putStrLn $ "[DAP][INFO][dapSetFunctionBreakpointsCommand] delete func bps " ++ show bps + + mapM_ (lift.delBreakpoint.show) bps + -- | + -- + getDelBPs = do + ctx <- takeMVar ctxMVar + + let bpNOs = funcBPsDAPContext ctx + + putMVar ctxMVar $ ctx {funcBPsDAPContext = []} + + return bpNOs + + -- | + -- + addBreakpoints args = do + let funcBPs = D.breakpointsSetFunctionBreakpointsArguments args + + addBps <- mapM addBP funcBPs + + liftIO $ updateBpCtx addBps + + return $ Right $ D.SetFunctionBreakpointsResponseBody addBps + + -- | + -- + addBP funcBP = do + let argStr = D.nameFunctionBreakpoint funcBP + + lift $ addBreakpoint argStr + + -- | + -- + updateBpCtx bps = do + ctx <- takeMVar ctxMVar + let cur = funcBPsDAPContext ctx + new = foldr getBpNo [] bps + putMVar ctxMVar $ ctx{funcBPsDAPContext = cur ++ new} + + -- | + -- + getBpNo bp acc = case D.idBreakpoint bp of + Nothing -> acc + Just no -> no : acc + + +------------------------------------------------------------------------------------------------ + +-- | +-- +delBreakpoint :: String -> G.GHCi Bool +delBreakpoint bpNoStr = do + curSt <- G.getGHCiState + let curCount = G.break_ctr curSt + + G.deleteCmd bpNoStr + + newSt <- G.getGHCiState + let newCount = G.break_ctr newSt + + return (newCount == curCount - 1) + + +-- | +-- +addBreakpoint :: String -> G.GHCi D.Breakpoint +addBreakpoint argStr = do + curSt <- G.getGHCiState + let curCount = G.break_ctr curSt + + G.breakCmd argStr + + newSt <- G.getGHCiState + let newCount = G.break_ctr newSt + isAdded = (newCount == curCount + 1) + locMay = if isAdded then Just (head (G.breaks newSt)) else Nothing + + withBreakLoc locMay + + where withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (G.breakLoc bpLoc) withBreakLoc Nothing = return D.defaultBreakpoint { D.verifiedBreakpoint = False @@ -262,62 +415,68 @@ , D.messageBreakpoint = "[DAP][ERROR] UnhelpfulSpan breakpoint." } - updateBreakpointTypeMap bp = case D.idBreakpoint bp of - Nothing -> return () - Just no -> do - -- D.verifiedBreakpoint should be False. - ctx <- takeMVar ctxMVar - let bpMap = bpTypeMapDAPContext ctx - newMap = M.insert no SourceBreakpoint bpMap - - putMVar ctxMVar ctx {bpTypeMapDAPContext = newMap} - --- | --- -delSrcBreakpintsInFile :: MVar DAPContext -> String -> InputT G.GHCi Bool -delSrcBreakpintsInFile ctxMVar path = deleteBreakpintsInFile ctxMVar path SourceBreakpoint +------------------------------------------------------------------------------------------------ +-- DAP Command :dap-continue +------------------------------------------------------------------------------------------------ -- | -- -delFuncBreakpintsInFile :: MVar DAPContext -> String -> InputT G.GHCi Bool -delFuncBreakpintsInFile ctxMVar path = deleteBreakpintsInFile ctxMVar path FunctionBreakpoint +dapContinueCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool +dapContinueCommand _ argsStr = do + withArgs (readDAP argsStr) >>= \case + res@(Left _) -> lift $ printDAP res + _ -> return () + return False + + where + withArgs :: Either String D.ContinueArguments -> InputT G.GHCi (Either String D.StoppedEventBody) + withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr + withArgs (Right args) = do + let expr = maybe "" id $ D.exprContinueArguments args + -- currently, thread id staticaly 0. + -- DAP result is shown in traceCmd. hacked. + lift $ G.traceCmd expr + + return $ Right D.defaultStoppedEventBody + + + +------------------------------------------------------------------------------------------------ +-- DAP Command :dap-next +------------------------------------------------------------------------------------------------ + -- | --- delete all breakpoint in the file. -- -deleteBreakpintsInFile :: MVar DAPContext -> String -> BreakpointType -> InputT G.GHCi Bool -deleteBreakpintsInFile ctxMVar path bpTye = do - bpMap <- liftIO $ bpTypeMapDAPContext <$> readMVar ctxMVar - st <- G.getGHCiState - let fileBpNOs = map fst $ filter (byFile path) $ G.breaks st - srcBpNOs = M.keys $ M.filter ((==) bpTye) bpMap - delBpNOs = intersect fileBpNOs srcBpNOs - - mapM_ callDelete delBpNOs +dapNextCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool +dapNextCommand _ argsStr = do + withArgs (readDAP argsStr) >>= \case + res@(Left _) -> lift $ printDAP res + _ -> return () return False - + where - byFile path (_, bs) = withSrcSpan path $ G.breakLoc bs - - withSrcSpan path (GHC.RealSrcSpan dat) = nzPath path == (nzPath . unpackFS . GHC.srcSpanFile) dat - withSrcSpan _ (GHC.UnhelpfulSpan _) = False - - callDelete bpNo = do - let bpNoStr = show bpNo - liftIO $ putStrLn $ "[DAP][INFO] delete breakpoint " ++ bpNoStr - lift $ G.deleteCmd bpNoStr + withArgs :: Either String D.NextArguments -> InputT G.GHCi (Either String D.StoppedEventBody) + withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr + withArgs (Right _) = do + -- currently, thread id staticaly 0. + -- DAP result is shown in stepLocalCmd. hacked. + lift $ G.stepLocalCmd "" + return $ Right D.defaultStoppedEventBody + + ------------------------------------------------------------------------------------------------ --- DAP Command :dap-continue +-- DAP Command :dap-step-in ------------------------------------------------------------------------------------------------ -- | -- -dapContinueCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool -dapContinueCommand _ argsStr = do +dapStepInCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool +dapStepInCommand _ argsStr = do withArgs (readDAP argsStr) >>= \case res@(Left _) -> lift $ printDAP res _ -> return () @@ -325,13 +484,12 @@ return False where - withArgs :: Either String D.ContinueArguments -> InputT G.GHCi (Either String D.StoppedEventBody) + withArgs :: Either String D.StepInArguments -> InputT G.GHCi (Either String D.StoppedEventBody) withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++ err ++ " : " ++ argsStr - withArgs (Right args) = do - let expr = maybe "" id $ D.exprContinueArguments args + withArgs (Right _) = do -- currently, thread id staticaly 0. - -- DAP result is show in traceCmd. hacked. - lift $ G.traceCmd expr + -- DAP result is shown in stepLocalCmd. hacked. + lift $ G.stepCmd "" return $ Right D.defaultStoppedEventBody @@ -349,7 +507,11 @@ -- | -- dapStackTraceCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool -dapStackTraceCommand _ argsStr = do +dapStackTraceCommand ctxMVar argsStr = do + + ctx <- liftIO $ takeMVar ctxMVar + liftIO $ putMVar ctxMVar ctx {frameIdDAPContext = 0} + res <- withArgs (readDAP argsStr) lift $ printDAP res return False @@ -361,17 +523,25 @@ [] -> return $ Left "no stacktrace found." (r:_) -> withResume r - withResume r = do - let start = resume2stackframe r - hists <- mapM resumeHist2stackFrame $ GHC.resumeHistory r - - let traces = start : hists + withResume r = case isExceptionResume r of + True -> do + traces <- mapM resumeHist2stackFrame $ GHC.resumeHistory r - return $ Right D.defaultStackTraceBody { - D.stackFramesStackTraceBody = traces - , D.totalFramesStackTraceBody = length traces - } + return $ Right D.defaultStackTraceBody { + D.stackFramesStackTraceBody = traces + , D.totalFramesStackTraceBody = length traces + } + False -> do + let start = resume2stackframe r + hists <- mapM resumeHist2stackFrame $ GHC.resumeHistory r + + let traces = start : hists + return $ Right D.defaultStackTraceBody { + D.stackFramesStackTraceBody = traces + , D.totalFramesStackTraceBody = length traces + } + resume2stackframe r = D.defaultStackFrame { D.idStackFrame = 0 , D.nameStackFrame = (getStackFrameTitle r) @@ -548,25 +718,10 @@ return $ conStr' ++ " :: " ++ typeStr getDataConstructor _ = return "[getDataConstructor] not supported type." --- | --- -showTermErrorHandler :: SomeException -> G.GHCi SDoc -showTermErrorHandler e = return $ text $ show e -- | -- -getNameTypeValue :: String -> (String, String, String) -getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr) - where - nameStr = takeWhile (/= ' ') str - typeStr = takeWhile (/= '=') $ drop 4 $ dropWhile (/= ' ') str - valueStr_ = tail $ dropWhile (/= '=') str - valueStr = if elem "->" (words typeStr) then "function :: " ++ typeStr - else valueStr_ - --- | --- getBindingVariablesNode :: MVar DAPContext -> Int -> G.GHCi [D.Variable] getBindingVariablesNode ctxMVar idx = do ctx <- liftIO $ readMVar ctxMVar @@ -657,11 +812,6 @@ return $ Right body xs -> return $ Left $ "not supported evaluate context [" ++ xs ++ "]." - --- | --- -parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name] -parseNameErrorHandler e = liftIO $ print e >> return [] -- | diff --git a/app/Haskell/DAP/GHCi/Type.hs b/app/Haskell/DAP/GHCi/Type.hs --- a/app/Haskell/DAP/GHCi/Type.hs +++ b/app/Haskell/DAP/GHCi/Type.hs @@ -13,21 +13,12 @@ -- | -- -data BreakpointType = SourceBreakpoint | FunctionBreakpoint - deriving (Show, Read, Eq) - --- | --- -type BreakpointTypeMap = M.Map Int BreakpointType - - --- | --- data DAPContext = DAPContext { variableReferenceMapDAPContext :: M.Map Int (Term, EvalString) , bindingDAPContext :: [GHC.TyThing] , frameIdDAPContext :: Int - , bpTypeMapDAPContext :: BreakpointTypeMap + , srcBPsDAPContext :: M.Map Int FilePath + , funcBPsDAPContext :: [Int] } @@ -38,7 +29,8 @@ variableReferenceMapDAPContext = M.fromList [] , bindingDAPContext = [] , frameIdDAPContext = 0 - , bpTypeMapDAPContext = M.fromList [] + , srcBPsDAPContext = M.fromList [] + , funcBPsDAPContext = [] } diff --git a/app/Haskell/DAP/GHCi/Utility.hs b/app/Haskell/DAP/GHCi/Utility.hs --- a/app/Haskell/DAP/GHCi/Utility.hs +++ b/app/Haskell/DAP/GHCi/Utility.hs @@ -1,19 +1,26 @@ -module Haskell.DAP.GHCi.Utility where +{-# LANGUAGE LambdaCase #-} -import qualified Data.Char as CH +module Haskell.DAP.GHCi.Utility where import qualified GHC - import qualified GHCi.UI.Monad as G +import HscTypes +import Outputable +import PprTyThing +import Debugger +import Exception +import DynFlags +import RtClosureInspect +import qualified Data.Char as CH import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T import qualified Data.Text as T +import qualified Data.List as L import qualified Text.Read as R import Data.Word import Control.Monad.IO.Class -import System.Console.Haskeline import Haskell.DAP.GHCi.Constant import qualified GHCi.DAP.IFData as D @@ -123,20 +130,140 @@ D.reasonStoppedEventBody = "complete" } :: Either String D.StoppedEventBody outStr = _DAP_HEADER ++ showDAP body + liftIO $ putStrLn "[DAP][INFO] debug complete" liftIO $ putStrLn outStr showStoppedEventBody (Just (GHC.ExecComplete { GHC.execResult = Left (SomeException e)})) = do let body = Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "exception" + D.reasonStoppedEventBody = "complete" , D.descriptionStoppedEventBody = show e + , D.textStoppedEventBody = show e } :: Either String D.StoppedEventBody outStr = _DAP_HEADER ++ showDAP body + liftIO $ putStrLn $ "[DAP][INFO] debug complete with exception. " ++ show e liftIO $ putStrLn outStr -showStoppedEventBody (Just GHC.ExecBreak{}) = do - let body = Right D.defaultStoppedEventBody { - D.reasonStoppedEventBody = "step" - } :: Either String D.StoppedEventBody - outStr = _DAP_HEADER ++ showDAP body - liftIO $ putStrLn outStr +showStoppedEventBody (Just GHC.ExecBreak{}) = getExceptionResume >>= \case + Nothing -> stoppedByBreak + Just _ -> stoopedWithException + + where + stoopedWithException = do + evalBody <- getEvalBody "_exception" True + let body = Right D.defaultStoppedEventBody { + D.reasonStoppedEventBody = "exception" + , D.descriptionStoppedEventBody = D.resultEvaluateBody evalBody + , D.textStoppedEventBody = D.resultEvaluateBody evalBody + } :: Either String D.StoppedEventBody + outStr = _DAP_HEADER ++ showDAP body + liftIO $ putStrLn "[DAP][INFO] break with exception." + liftIO $ putStrLn outStr + + stoppedByBreak = do + let body = Right D.defaultStoppedEventBody { + D.reasonStoppedEventBody = "step" + } :: Either String D.StoppedEventBody + outStr = _DAP_HEADER ++ showDAP body + + liftIO $ putStrLn "[DAP][INFO] breaks." + liftIO $ putStrLn outStr + + +-- | +-- +getExceptionResume :: G.GHCi (Maybe GHC.Resume) +getExceptionResume = GHC.getResumeContext >>= \case + [] -> return Nothing + (x:_) -> if isExceptionResume x then return (Just x) + else return Nothing + +-- | +-- +isExceptionResume :: GHC.Resume -> Bool +isExceptionResume r = L.isInfixOf "exception" (GHC.resumeDecl r) + + + +-- | +-- +parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name] +parseNameErrorHandler e = liftIO $ print e >> return [] + + +-- | +-- +showTermErrorHandler :: SomeException -> G.GHCi SDoc +showTermErrorHandler e = return $ text $ show e + + +-- | +-- +-- +getEvalBody :: String -> Bool -> G.GHCi D.EvaluateBody +getEvalBody nameStr isForce = + gcatch (GHC.parseName nameStr) parseNameErrorHandler >>= withNames + + where + withNames [] = return D.defaultEvaluateBody { + D.resultEvaluateBody = "Not in scope: " ++ nameStr + , D.typeEvaluateBody = "force error." + , D.variablesReferenceEvaluateBody = 0 + } + withNames (n:[]) = GHC.lookupName n >>= \case + Just ty -> withTyThing ty + Nothing -> return D.defaultEvaluateBody { + D.resultEvaluateBody = "variable not found. " ++ nameStr + , D.typeEvaluateBody = "force error." + , D.variablesReferenceEvaluateBody = 0 + } + withNames _ = return D.defaultEvaluateBody { + D.resultEvaluateBody = "ambiguous name" ++ nameStr + , D.typeEvaluateBody = "force error." + , D.variablesReferenceEvaluateBody = 0 + } + + withTyThing (AnId i) = GHC.obtainTermFromId maxBound isForce i >>= withTerm i + + withTyThing x = do + dflags <- getDynFlags + return D.defaultEvaluateBody { + D.resultEvaluateBody = "unsupported tything. " ++ showSDoc dflags (ppr x) + , D.typeEvaluateBody = "force error." + , D.variablesReferenceEvaluateBody = 0 + } + + -- | + -- Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html + -- + withTerm :: GHC.Id -> Term -> G.GHCi D.EvaluateBody + withTerm _ t@(Term ty _ _ _) = do + dflags <- getDynFlags + termSDoc <- gcatch (showTerm t) showTermErrorHandler + let typeStr = showSDoc dflags (pprTypeForUser ty) + valStr = showSDoc dflags termSDoc + + return D.defaultEvaluateBody { + D.resultEvaluateBody = valStr + , D.typeEvaluateBody = typeStr + } + + withTerm i _ = do + dflags <- getDynFlags + idSDoc <- pprTypeAndContents i + let (_, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc) + return D.defaultEvaluateBody { + D.resultEvaluateBody = valStr + , D.typeEvaluateBody = typeStr + } + +-- | +-- +getNameTypeValue :: String -> (String, String, String) +getNameTypeValue str = (strip nameStr, strip typeStr, strip valueStr) + where + nameStr = takeWhile (/= ' ') str + typeStr = takeWhile (/= '=') $ drop 4 $ dropWhile (/= ' ') str + valueStr_ = tail $ dropWhile (/= '=') str + valueStr = if elem "->" (words typeStr) then "function :: " ++ typeStr + else valueStr_ diff --git a/haskell-dap.cabal b/haskell-dap.cabal --- a/haskell-dap.cabal +++ b/haskell-dap.cabal @@ -1,5 +1,5 @@ name: haskell-dap -version: 0.0.3.0 +version: 0.0.4.0 synopsis: haskell-dap is a GHCi having DAP interface. description: Please see README.md homepage: https://github.com/phoityne/haskell-dap diff --git a/src/GHCi/DAP/IFData.hs b/src/GHCi/DAP/IFData.hs --- a/src/GHCi/DAP/IFData.hs +++ b/src/GHCi/DAP/IFData.hs @@ -17,10 +17,18 @@ , SetBreakpointsResponseBody(..) , Breakpoint(..) , defaultBreakpoint + -- * setFunctionBreakpoints + , SetFunctionBreakpointsArguments(..) + , FunctionBreakpoint(..) + , SetFunctionBreakpointsResponseBody(..) -- * continue , ContinueArguments(..) , StoppedEventBody(..) , defaultStoppedEventBody + -- * next + , NextArguments(..) + -- * stepIn + , StepInArguments(..) -- * scopes , ScopesArguments(..) , ScopesBody(..) @@ -334,13 +342,64 @@ } +------------------------------------------------------------------------------------ + -- | +-- Arguments for 'setFunctionBreakpoints' request. +-- +data SetFunctionBreakpointsArguments = + SetFunctionBreakpointsArguments { + breakpointsSetFunctionBreakpointsArguments :: [FunctionBreakpoint] -- The function names of the breakpoints. + } deriving (Show, Read, Eq) + + +-- | +-- Properties of a breakpoint passed to the setFunctionBreakpoints request. +-- +data FunctionBreakpoint = + FunctionBreakpoint { + nameFunctionBreakpoint :: String -- The name of the function. + , conditionFunctionBreakpoint :: Maybe String -- An optional expression for conditional breakpoints. + , hitConditionFunctionBreakpoint :: Maybe String -- An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed. + } deriving (Show, Read, Eq) + + +-- | +-- Response to 'setFunctionBreakpoints' request. +-- Returned is information about each breakpoint created by this request. +-- +data SetFunctionBreakpointsResponseBody = + SetFunctionBreakpointsResponseBody { + breakpointsSetFunctionBreakpointsResponseBody :: [Breakpoint] -- Information about the breakpoints. The array elements correspond to the elements of the 'breakpoints' array. + } deriving (Show, Read, Eq) + + ------------------------------------------------------------------------------------ + +-- | -- Arguments for 'continue' request. -- data ContinueArguments = ContinueArguments { threadIdContinueArguments :: Int -- ^Continue execution for the specified thread (if possible). If the backend cannot continue on a single thread but will continue on all threads, it should set the allThreadsContinued attribute in the response to true. , exprContinueArguments :: Maybe String -- ^ADD: haskell-dap + } deriving (Show, Read, Eq) + + +-- | +-- Arguments for 'next' request. +-- +data NextArguments = + NextArguments { + threadIdNextArguments :: Int -- Execute 'next' for this thread. + } deriving (Show, Read, Eq) + + +-- | +-- Arguments for 'stepIn' request. +-- +data StepInArguments = + StepInArguments { + threadIdStepInArguments :: Int -- Execute 'stepIn' for this thread. } deriving (Show, Read, Eq)