haskell-dap 0.0.3.0 → 0.0.4.0

raw patch · 9 files changed

+466/−123 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +5/−0
• README.md +8/−2
• app-ghc-8.0/GHCi/UI.hs +3/−1
• app-ghc-8.2/GHCi/UI.hs +3/−1
• app/Haskell/DAP/GHCi/Command.hs +245/−95
• app/Haskell/DAP/GHCi/Type.hs +4/−12
• app/Haskell/DAP/GHCi/Utility.hs +138/−11
• haskell-dap.cabal +1/−1
• src/GHCi/DAP/IFData.hs +59/−0

@@ -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.

@@ -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) 

@@ -31,7 +31,9 @@         getLoadedModules,         breakCmd,         deleteCmd,-        traceCmd+        traceCmd,+        stepCmd,+        stepLocalCmd     ) where  #include "HsVersions.h"

@@ -31,7 +31,9 @@         getLoadedModules,         breakCmd,         deleteCmd,-        traceCmd+        traceCmd,+        stepCmd,+        stepLocalCmd     ) where  #include "HsVersions.h"

@@ -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 []
 
 
 -- |

@@ -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 = []
   }
 
   

@@ -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_
 

@@ -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

@@ -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)