haskell-dap 0.0.2.0 → 0.0.3.0

raw patch · 11 files changed

+833/−164 lines, 11 filesdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: text

API changes (from Hackage documentation)

Files

• Changelog.md +5/−0
• README.md +8/−2
• app-ghc-8.0/GHCi/UI.hs +15/−4
• app-ghc-8.2/GHCi/UI.hs +16/−4
• app/Haskell/DAP/GHCi/Command.hs +377/−145
• app/Haskell/DAP/GHCi/Constant.hs +1/−0
• app/Haskell/DAP/GHCi/Type.hs +13/−1
• app/Haskell/DAP/GHCi/Utility.hs +127/−2
• app/Main.hs +3/−2
• haskell-dap.cabal +2/−1
• src/GHCi/DAP/IFData.hs +266/−3

@@ -1,4 +1,9 @@ +20180225 haskell-dap-0.0.3.0++  * [ADD] setBreakpoint, continue, scopes, stackTrace, evaluate commands.++ 20180121 haskell-dap-0.0.2.0    * [MODIFY] using GHC.Paths module to set libdir.

@@ -3,10 +3,12 @@  The goal is "let GHCi speak [DAP](https://code.visualstudio.com/docs/extensions/example-debuggers)". +![goal.png](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/goal.png)  + ## Information -* [2018/01/21] Release haskel-dap-0.0.2.0.  -  * [MODIFY] using GHC.Paths module to set libdir.+* [2018/02/25] Release haskel-dap-0.0.3.0.  +  * [ADD] setBreakpoint, continue, scopes, stackTrace, evaluate commands.   ## Limitation@@ -43,6 +45,10 @@     "ghciCmd": "stack ghci --with-ghc=haskell-dap --test --no-load --no-build --main-is TARGET --ghci-options -fprint-evld-with-show ",  ++## IFData Design++![if_data.png](https://raw.githubusercontent.com/phoityne/haskell-dap/master/docs/if_data.png)     

@@ -23,9 +23,15 @@ module GHCi.UI (         interactiveUI,         GhciSettings(..),-        defaultGhciSettings,         ghciCommands,-        ghciWelcomeMsg+        ghciWelcomeMsg,++        -- haskell-dap add.+        defaultGhciSettings,+        getLoadedModules,+        breakCmd,+        deleteCmd,+        traceCmd     ) where  #include "HsVersions.h"@@ -123,6 +129,10 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) ++import qualified Haskell.DAP.GHCi.Utility as DAP++ -----------------------------------------------------------------------------  data GhciSettings = GhciSettings {@@ -2933,7 +2943,7 @@ stepCmd arg = withSandboxOnly ":step" $ step arg   where   step []         = doContinue (const True) GHC.SingleStep-  step expression = runStmt expression GHC.SingleStep >> return ()+  step expression = runStmt expression GHC.SingleStep >>= DAP.showStoppedEventBody >> return ()  stepLocalCmd :: String -> GHCi () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg@@ -2985,7 +2995,7 @@   = withSandboxOnly ":trace" $ tr arg   where   tr []         = doContinue (const True) GHC.RunAndLogSteps-  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()+  tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.showStoppedEventBody >> return ()  continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -2994,6 +3004,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do   runResult <- resume pre step+  DAP.showStoppedEventBody (Just runResult)   _ <- afterRunStmt pre runResult   return () 

@@ -23,9 +23,15 @@ module GHCi.UI (         interactiveUI,         GhciSettings(..),-        defaultGhciSettings,         ghciCommands,-        ghciWelcomeMsg+        ghciWelcomeMsg,++        -- haskell-dap add.+        defaultGhciSettings,+        getLoadedModules,+        breakCmd,+        deleteCmd,+        traceCmd     ) where  #include "HsVersions.h"@@ -132,6 +138,10 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) ++import qualified Haskell.DAP.GHCi.Utility as DAP++ -----------------------------------------------------------------------------  data GhciSettings = GhciSettings {@@ -3135,7 +3145,7 @@ stepCmd arg = withSandboxOnly ":step" $ step arg   where   step []         = doContinue (const True) GHC.SingleStep-  step expression = runStmt expression GHC.SingleStep >> return ()+  step expression = runStmt expression GHC.SingleStep >>= DAP.showStoppedEventBody >> return ()  stepLocalCmd :: String -> GHCi () stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg@@ -3187,7 +3197,7 @@   = withSandboxOnly ":trace" $ tr arg   where   tr []         = doContinue (const True) GHC.RunAndLogSteps-  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()+  tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.showStoppedEventBody >> return ()  continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -3196,6 +3206,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do   runResult <- resume pre step+  DAP.showStoppedEventBody (Just runResult)   _ <- afterRunStmt pre runResult   return () @@ -3769,3 +3780,4 @@                then noCanDo n $ text "module " <> ppr modl <>                                 text " is not interpreted"                else and_then n+

@@ -12,6 +12,8 @@ import DataCon
 import DynFlags
 import RtClosureInspect
+import Data.List
+import qualified GHCi.UI as G
 import qualified GHCi.UI.Monad as G
 
 import Control.DeepSeq (deepseq)
@@ -20,8 +22,8 @@ import Control.Concurrent
 import Control.Monad
 
-import Data.Char
 import qualified Data.Map as M
+import qualified Data.List as L
 
 import System.Console.Haskeline
 
@@ -31,15 +33,20 @@ import Haskell.DAP.GHCi.Utility
 
 
+
 -- |
 --
 dapCommands :: MVar DAPContext -> [G.Command]
 dapCommands ctx = map mkCmd [
-    ("dap-echo",     dapEcho,                noCompletion)
-  , ("dap-bindings", dapBindingsCommand ctx, noCompletion)
-  , ("dap-force",    dapForceCommand ctx,    noCompletion)
-  , ("dap-scopes",   dapScopesCommand ctx,   noCompletion)
-  , ("dap-history",  dapHistoryCommand ctx,  noCompletion)
+    ("dap-echo",            dapEcho,                      noCompletion)
+  --, ("dap-force",           dapForceCommand ctx,          noCompletion)
+  , ("dap-scopes",          dapScopesCommand ctx,         noCompletion)
+  , ("dap-history",         dapHistoryCommand ctx,        noCompletion)
+  , ("dap-set-breakpoints", dapSetBreakpointsCommand ctx, noCompletion)
+  , ("dap-continue",        dapContinueCommand ctx,       noCompletion)
+  , ("dap-stacktrace",      dapStackTraceCommand ctx,     noCompletion)
+  , ("dap-variables",       dapVariablesCommand ctx,      noCompletion)
+  , ("dap-evaluate",        dapEvaluateCommand ctx,       noCompletion)
   ]
   where
     mkCmd (n,a,c) = G.Command { G.cmdName = n
@@ -80,46 +87,373 @@ 
 
 ------------------------------------------------------------------------------------------------
---  DAP Command :dap-bindings
+--  DAP Command :dap-scopes
 ------------------------------------------------------------------------------------------------
 
 -- |
 --
+dapScopesCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapScopesCommand 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) = do
+      let idx  = D.frameIdScopesArguments args
+      lift $ getScopesBody idx
+
+    -- |
+    --
+    getScopesBody :: Int -> G.GHCi (Either String D.ScopesBody)
+    getScopesBody curIdx = do
+      -- liftIO $ putStrLn $ "[DAP][getScopesBody] frame id." ++ frameIdStr
+      oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar
+      let moveIdx = curIdx - oldIdx
+
+      tyThings <- withMoveIdx moveIdx
+
+      -- liftIO $ putStrLn $ "[DAP][getScopesBody] tyThings count." ++ show (length tyThings)
+      ctx <- liftIO $ takeMVar ctxMVar
+      liftIO $ putMVar ctxMVar ctx {
+        variableReferenceMapDAPContext = M.empty
+        , bindingDAPContext = tyThings
+        , frameIdDAPContext = curIdx
+        }
+    
+      return $ Right D.ScopesBody {
+        D.scopesScopesBody = [
+          D.defaultScope{
+              D.nameScope = _GHCi_SCOPE
+            , D.variablesReferenceScope = 1
+            , D.namedVariablesScope = Nothing
+            , D.indexedVariablesScope = Nothing
+            , D.expensiveScope = False
+            }
+          ]
+        }
+
+    -- |
+    --
+    withMoveIdx moveIdx
+      | 0 == moveIdx = GHC.getBindings
+      | 0 < moveIdx = back moveIdx
+      | otherwise = forward moveIdx
+  
+    -- |
+    --
+    back num = do
+      (names, _, _, _) <- GHC.back num
+      st <- G.getGHCiState
+      enqueueCommands [G.stop st]
+
+      foldM withName [] $ reverse names
+
+    -- |
+    --
+    forward num = do
+      (names, _, _, _) <- GHC.forward num
+      st <- G.getGHCiState
+      enqueueCommands [G.stop st]
+
+      foldM withName [] $ reverse names
+           
+    -- |
+    --
+    enqueueCommands :: [String] -> G.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 ()
+      G.modifyGHCiState $ \st -> st{ G.cmdqueue = cmds ++ G.cmdqueue st }
+
+    -- |
+    --
+    withName acc n = GHC.lookupName n >>= \case
+      Just ty -> return (ty : acc)
+      Nothing ->  do
+        dflags <- getDynFlags
+        liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] variable not found. " ++ showSDoc dflags (ppr n)
+        return acc
+
+      
+------------------------------------------------------------------------------------------------
+--  DAP Command :dap-set-breakpoints
+------------------------------------------------------------------------------------------------
+
+-- |
 --
-dapBindingsCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
-dapBindingsCommand ctxMVar idxStr = do
+dapSetBreakpointsCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapSetBreakpointsCommand ctxMVar argsStr = do
+  res <- withArgs (readDAP argsStr) 
+  lift $ printDAP res
+  return False
 
-  body <- lift $ getVariablesBody ctxMVar idxStr
+  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
 
-  let outStr = _DAP_HEADER ++ (show body)
+      modSums <- G.getLoadedModules
+      let modPaths = map takeModPath modSums
+
+      case filter (isPathMatch srcPath) modPaths of
+        ((m, p):[]) -> do
+          liftIO $ putStrLn $ "[DAP][INFO][dapBreakCommand] " ++ 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
+
+      return $ Right $ D.SetBreakpointsResponseBody addBps
+    
+    go mod srcBP = do
+      curSt <- G.getGHCiState
+      let curCount = G.break_ctr curSt
+          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
+      
+      withBreakLoc locMay
+      
+    withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (G.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 . G.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."
+      }
+
+    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
+
+-- |
+--
+delFuncBreakpintsInFile :: MVar DAPContext -> String -> InputT G.GHCi Bool
+delFuncBreakpintsInFile ctxMVar path = deleteBreakpintsInFile ctxMVar path FunctionBreakpoint
+
+-- |
+--   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
+
+  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
+
+
+------------------------------------------------------------------------------------------------
+--  DAP Command :dap-continue
+------------------------------------------------------------------------------------------------
+
+-- |
+--
+dapContinueCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapContinueCommand _ argsStr = do
+  withArgs (readDAP argsStr) >>= \case
+    res@(Left _) -> lift $ printDAP res
+    _ -> return ()
+
+  return False
   
-  liftIO $ putStrLn outStr
+  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 show in traceCmd. hacked.
+      lift $ G.traceCmd expr
 
+      return $ Right D.defaultStoppedEventBody
+
+
+------------------------------------------------------------------------------------------------
+--  DAP Command :dap-stacktrace
+------------------------------------------------------------------------------------------------
+
+-- |
+-- 
+_MAX_STACK_TRACE_SIZE :: Int
+_MAX_STACK_TRACE_SIZE = 50
+
+
+-- |
+--
+dapStackTraceCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapStackTraceCommand _ argsStr = do
+  res <- withArgs (readDAP argsStr) 
+  lift $ printDAP res
   return False
+  
+  where
+    withArgs :: Either String D.StackTraceArguments ->  InputT G.GHCi (Either String D.StackTraceBody)
+    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
+    withArgs (Right _) = GHC.getResumeContext >>= \case
+      [] -> return $ Left "no stacktrace found."
+      (r:_) -> withResume r
 
+    withResume r = 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)
+      , 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
+------------------------------------------------------------------------------------------------
+
 -- |
 --
-getVariablesBody :: MVar DAPContext -> String -> G.GHCi D.VariablesBody
-getVariablesBody ctxMVar idxStr = do
+dapVariablesCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapVariablesCommand ctxMVar argsStr = do
+  res <- withArgs (readDAP argsStr) 
+  lift $ printDAP res
+  return False
 
-  vals <- getBindigVariables ctxMVar idxStr
+  where
+    withArgs :: Either String D.VariablesArguments -> InputT G.GHCi (Either String D.VariablesBody)
+    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
+    withArgs (Right args) = do
+      let idx  = D.variablesReferenceVariablesArguments args
 
-  return $ D.VariablesBody vals
+      vals <- lift $ getBindingVariables ctxMVar idx
 
+      return $ Right $ D.VariablesBody vals
 
+
 -- |
 --
-getBindigVariables :: MVar DAPContext -> String -> G.GHCi [D.Variable]
-getBindigVariables ctx idStr 
-  | "1" == idStr = getBindigVariablesRoot ctx 
-  | otherwise    = getBindigVariablesNode ctx idStr 
+getBindingVariables :: MVar DAPContext -> Int -> G.GHCi [D.Variable]
+getBindingVariables ctx idx
+  | 1 == idx = getBindingVariablesRoot ctx 
+  | otherwise  = getBindingVariablesNode ctx idx
 
 
 -- |
 --
-getBindigVariablesRoot :: MVar DAPContext -> G.GHCi [D.Variable]
-getBindigVariablesRoot ctxMVar = do
+getBindingVariablesRoot :: MVar DAPContext -> G.GHCi [D.Variable]
+getBindingVariablesRoot ctxMVar = do
   bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar
   -- liftIO $ putStrLn $ "[DAP][INFO] bindings " ++ show (length bindings)
 
@@ -197,7 +531,7 @@   let curMap = variableReferenceMapDAPContext ctx
       nextId = (M.size curMap) + 2
 
-  putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert (show nextId) (t, str) curMap}
+  putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap}
 
   return nextId
 
@@ -233,13 +567,13 @@ 
 -- |
 --
-getBindigVariablesNode :: MVar DAPContext -> String -> G.GHCi [D.Variable]
-getBindigVariablesNode ctxMVar idStr = do
+getBindingVariablesNode :: MVar DAPContext -> Int -> G.GHCi [D.Variable]
+getBindingVariablesNode ctxMVar idx = do
   ctx <- liftIO $ readMVar ctxMVar
-  case M.lookup idStr (variableReferenceMapDAPContext ctx) of
+  case M.lookup idx (variableReferenceMapDAPContext ctx) of
     Just (t, str)  -> withTerm t str
     Nothing -> do
-      liftIO $ putStrLn $ "[DAP][ERROR][getBindigVariablesNode] id not found. " ++ idStr
+      liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] id not found. " ++ show idx
       return []
 
   where
@@ -254,7 +588,7 @@       mapM (withSubTerm str) $ zip labels subTerms
 
     withTerm _ _ = do
-      liftIO $ putStrLn $ "[DAP][ERROR][getBindigVariablesNode] invalid map term type. " ++ idStr
+      liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] invalid map term type. " ++ show idx
       return []
 
     withSubTerm evalStr (label, t@(Term ty _ _ _)) = do
@@ -294,8 +628,7 @@       , D.evaluateNameVariable = Just evalStr
       , D.variablesReferenceVariable = 0
       }
-    withSubTerm evalStr (label, _) = do
-      return D.defaultVariable {
+    withSubTerm evalStr (label, _) = return D.defaultVariable {
         D.nameVariable  = label
       , D.typeVariable  = "not supported subTerm."
       , D.valueVariable = "not supported subTerm."
@@ -303,27 +636,28 @@       , D.variablesReferenceVariable = 0
       }
 
-
-
 ------------------------------------------------------------------------------------------------
---  DAP Command :dap-force
+--  DAP Command :dap-evaluate
 ------------------------------------------------------------------------------------------------
 
 -- |
 --
---
-dapForceCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
-dapForceCommand ctx valStr = do
-
-  body <- lift $ getForceEvalBody ctx valStr
-
-  let outStr = _DAP_HEADER ++ (show body)
-  
-  liftIO $ putStrLn outStr
-
+dapEvaluateCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
+dapEvaluateCommand ctxMVar argsStr = do
+  res <- withArgs (readDAP argsStr) 
+  lift $ printDAP res
   return False
 
+  where
+    withArgs :: Either String D.EvaluateArguments -> InputT G.GHCi (Either String D.EvaluateBody)
+    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
+    withArgs (Right args) = case D.contextEvaluateArguments args of
+      "watch" -> do
+        body <- lift $ getForceEvalBody ctxMVar $ D.expressionEvaluateArguments args
+        return $ Right body
+      xs -> return $ Left $ "not supported evaluate context [" ++ xs ++ "]."
 
+
 -- |
 --
 parseNameErrorHandler :: SomeException -> G.GHCi [GHC.Name]
@@ -396,105 +730,3 @@              , D.variablesReferenceEvaluateBody = 0
              }
 
-
-------------------------------------------------------------------------------------------------
---  DAP Command :dap-scopes
-------------------------------------------------------------------------------------------------
-
--- |
---
-dapScopesCommand :: MVar DAPContext -> String -> InputT G.GHCi Bool
-dapScopesCommand ctx idxStr = do
-
-  vals <- lift $ getScopesBody ctx idxStr
-
-  let outStr = _DAP_HEADER ++ (show vals)
-  
-  liftIO $ putStrLn outStr
-
-  return False
-
-
--- |
---
-getScopesBody :: MVar DAPContext -> String -> G.GHCi D.ScopesBody
-getScopesBody ctxMVar frameIdStr 
-  | all isDigit frameIdStr = do
-    -- liftIO $ putStrLn $ "[DAP][getScopesBody] frame id." ++ frameIdStr
-    oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar
-    let curIdx  = read frameIdStr
-        moveIdx = curIdx - oldIdx
-
-    tyThings <- withMoveIdx moveIdx
-
-    -- liftIO $ putStrLn $ "[DAP][getScopesBody] tyThings count." ++ show (length tyThings)
-    ctx <- liftIO $ takeMVar ctxMVar
-    liftIO $ putMVar ctxMVar ctx {
-       variableReferenceMapDAPContext = M.empty
-      , bindingDAPContext = tyThings
-      , frameIdDAPContext = curIdx
-      }
-  
-    return D.ScopesBody {
-      D.scopesScopesBody = [
-        D.defaultScope{
-            D.nameScope = _GHCi_SCOPE
-          , D.variablesReferenceScope = 1
-          , D.namedVariablesScope = Nothing
-          , D.indexedVariablesScope = Nothing
-          , D.expensiveScope = False
-          }
-        ]
-      }
-  | otherwise = do
-    liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] invalid frame id." ++ frameIdStr
-    return D.ScopesBody {
-      D.scopesScopesBody = [D.defaultScope{D.nameScope = "invalid frame id." ++ frameIdStr}]
-    }
-
-  where
-    -- |
-    --
-    withMoveIdx moveIdx
-      | 0 == moveIdx = GHC.getBindings
-      | 0 < moveIdx = back moveIdx
-      | otherwise = forward moveIdx
-  
-    -- |
-    --
-    back num = do
-      (names, _, _, _) <- GHC.back num
-      st <- G.getGHCiState
-      enqueueCommands [G.stop st]
-
-      foldM withName [] $ reverse names
-
-    -- |
-    --
-    forward num = do
-      (names, _, _, _) <- GHC.forward num
-      st <- G.getGHCiState
-      enqueueCommands [G.stop st]
-
-      foldM withName [] $ reverse names
-           
-    -- |
-    --
-    enqueueCommands :: [String] -> G.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 ()
-      G.modifyGHCiState $ \st -> st{ G.cmdqueue = cmds ++ G.cmdqueue st }
-
-    -- |
-    --
-    withName acc n = GHC.lookupName n >>= \case
-      Just ty -> return (ty : acc)
-      Nothing ->  do
-        dflags <- getDynFlags
-        liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] variable not found. " ++ showSDoc dflags (ppr n)
-        return acc
-    
-  

@@ -7,6 +7,7 @@ _DAP_HEADER = "<<DAP>>"
 
 
+
 -- |
 --
 _GHCi_SCOPE :: String

@@ -13,10 +13,21 @@ 
 -- |
 --
+data BreakpointType = SourceBreakpoint | FunctionBreakpoint
+  deriving (Show, Read, Eq)
+
+-- |
+--
+type BreakpointTypeMap = M.Map Int BreakpointType
+
+
+-- |
+--
 data DAPContext = DAPContext {
-    variableReferenceMapDAPContext :: M.Map String (Term, EvalString)
+    variableReferenceMapDAPContext :: M.Map Int (Term, EvalString)
   , bindingDAPContext :: [GHC.TyThing]
   , frameIdDAPContext :: Int
+  , bpTypeMapDAPContext :: BreakpointTypeMap
   }
 
   
@@ -27,6 +38,7 @@     variableReferenceMapDAPContext = M.fromList []
   , bindingDAPContext = []
   , frameIdDAPContext = 0
+  , bpTypeMapDAPContext = M.fromList []
   }
 
   

@@ -1,8 +1,37 @@ module Haskell.DAP.GHCi.Utility where
 
-  
+import qualified Data.Char as CH
+
+import qualified GHC
+
+import qualified GHCi.UI.Monad as G
+
+import qualified Data.ByteString as BS
+import qualified Data.Text.Encoding as T
+import qualified Data.Text as T
+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
+
 -- |
 --
+_SLASH :: Char
+_SLASH = '/'
+
+
+-- |
+--
+_BACK_SLASH :: Char
+_BACK_SLASH = '\\'
+
+
+-- |
+--
 _SPACES :: [Char]
 _SPACES = [' ', '\n', '\t']
 
@@ -14,4 +43,100 @@ rstrip = reverse . lstrip . reverse
 strip  = lstrip . rstrip
 
-  +
+-- |
+--
+toLower :: String -> String
+toLower = map CH.toLower
+
+
+-- |
+--
+toUpper :: String -> String
+toUpper = map CH.toUpper
+
+
+-- |
+--
+win2unixSlash :: String -> String
+win2unixSlash = map (\c -> if c == _BACK_SLASH then _SLASH else c)
+
+
+-- |
+--
+unix2winSlash :: String -> String
+unix2winSlash = map (\c -> if c == _SLASH then _BACK_SLASH else c)
+
+
+-- |
+--   normalized path
+--
+nzPath :: FilePath -> FilePath
+nzPath = drive2lower . win2unixSlash
+
+
+-- |
+--  to lowercase Windows drive letter 
+-- 
+drive2lower :: FilePath -> FilePath
+drive2lower (x : ':' : xs) = CH.toLower x : ':' : xs
+drive2lower xs = xs
+
+
+------------------------------------------------------------------------------------------------
+--  DAP Utility
+------------------------------------------------------------------------------------------------
+
+-- |
+--
+readDAP :: Read a => String -> Either String a
+readDAP argsStr = case R.readEither argsStr :: Either String [Word8] of
+  Left err -> Left $ "read [Word8] failed. " ++ err ++ " : " ++ argsStr
+  Right bs -> case R.readEither (toStr bs) of
+    Left err -> Left $ "read response body failed. " ++ err ++ " : " ++  (toStr bs)
+    Right a  -> Right a 
+  where
+    toStr = T.unpack . T.decodeUtf8 . BS.pack
+
+
+-- |
+--
+showDAP :: Show a => a -> String
+showDAP = show . BS.unpack . T.encodeUtf8 . T.pack . show
+
+
+-- |
+--
+printDAP :: Show a => a -> G.GHCi ()
+printDAP dat = do
+  let outStr = _DAP_HEADER ++ showDAP dat
+
+  liftIO $ putStrLn outStr
+
+
+-- |
+--
+showStoppedEventBody :: Maybe GHC.ExecResult -> G.GHCi ()
+showStoppedEventBody Nothing = return ()
+showStoppedEventBody (Just (GHC.ExecComplete { GHC.execResult = Right _ })) = do
+  let body = Right D.defaultStoppedEventBody {
+             D.reasonStoppedEventBody = "complete"
+           } :: Either String D.StoppedEventBody
+      outStr = _DAP_HEADER ++ showDAP body
+  liftIO $ putStrLn outStr
+  
+showStoppedEventBody (Just (GHC.ExecComplete { GHC.execResult = Left (SomeException e)})) = do
+  let body = Right D.defaultStoppedEventBody {
+             D.reasonStoppedEventBody = "exception"
+           , D.descriptionStoppedEventBody = show e
+           } :: Either String D.StoppedEventBody
+      outStr = _DAP_HEADER ++ showDAP body
+  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
+

@@ -9,14 +9,15 @@ import Haskell.DAP.GHCi.Command import Haskell.DAP.GHCi.Type -+import Paths_haskell_dap (version)+import Data.Version  -- | --  Main -- main :: IO () main = do-  putStrLn "[DAP][INFO] start haskell-dap."+  putStrLn $ "[DAP][INFO] start haskell-dap-" ++ showVersion version ++ "."    mvarCtx <- newMVar defaultDAPContext 

@@ -1,5 +1,5 @@ name:                  haskell-dap-version:               0.0.2.0+version:               0.0.3.0 synopsis:              haskell-dap is a GHCi having DAP interface. description:           Please see README.md homepage:              https://github.com/phoityne/haskell-dap@@ -66,6 +66,7 @@                      , bytestring                      , deepseq                      , haskell-dap+                     , text   if os(windows)     build-depends:       Win32

@@ -10,16 +10,59 @@ @see : https://github.com/Microsoft/vscode-debugadapter-node/blob/master/protocol/src/debugProtocol.ts  -}-module GHCi.DAP.IFData where+module GHCi.DAP.IFData (+    -- * setBreakpoints+    SetBreakpointsArguments(..)+  , SourceBreakpoint(..)+  , SetBreakpointsResponseBody(..)+  , Breakpoint(..)+  , defaultBreakpoint+    -- * continue+  , ContinueArguments(..)+  , StoppedEventBody(..)+  , defaultStoppedEventBody+    -- * scopes+  , ScopesArguments(..)+  , ScopesBody(..)+  , Scope(..)+  , defaultScope+    -- * stackTrace+  , StackTraceArguments(..)+  , StackTraceBody(..)+  , defaultStackTraceBody+  , StackFrame(..)+  , defaultStackFrame+    -- * variables+  , VariablesArguments(..)+  , VariablesBody(..)+  , Variable(..)+  , defaultVariable+    -- * evaluate+  , EvaluateArguments(..)+  , EvaluateBody(..)+  , defaultEvaluateBody+    -- * commons+  , VariablePresentationHint(..)+  , Source(..)+  , defaultSource+) where  +-- |+--   Arguments for 'variables' request. +--+data VariablesArguments =+  VariablesArguments {+    variablesReferenceVariablesArguments :: Int  -- ^The Variable reference.+  } deriving (Show, Read, Eq) + -- | --    Response to "variables" request. -- data VariablesBody =   VariablesBody {-    variablesVariablesBody :: [Variable]  -- All (or a range) of variables for the given variable reference.+    variablesVariablesBody :: [Variable]  -- ^All (or a range) of variables for the given variable reference.   } deriving (Show, Read, Eq)  @@ -112,6 +155,29 @@   -- |+--   rguments for 'evaluate' request.+--+data EvaluateArguments =+  EvaluateArguments {+    expressionEvaluateArguments :: String     -- ^The expression to evaluate. +  , frameIdEvaluateArguments    :: Maybe Int  -- ^Evaluate the expression in the scope of this stack frame. If not specified, the expression is evaluated in the global scope. ++  {-|+    The context in which the evaluate request is run.+    Values:+    'watch': evaluate is run in a watch.++    'repl': evaluate is run from REPL console.++    'hover': evaluate is run from a data hover.+    +    etc. +  -}+  , contextEvaluateArguments    :: String+    } deriving (Show, Read, Eq)++    +-- | --    Response to "evaluate" request.  -- data EvaluateBody =@@ -138,8 +204,17 @@   -- |---   SResponse to 'scopes' request.+--   Arguments for "scopes" request. --+data ScopesArguments =+  ScopesArguments {+    frameIdScopesArguments :: Int  -- ^Retrieve the scopes for this stackframe.+  } deriving (Show, Read, Eq)+++-- |+--   Response to 'scopes' request.+-- data ScopesBody =   ScopesBody {     scopesScopesBody :: [Scope]  -- ^The scopes of the stackframe. If the array has length zero, there are no scopes available.@@ -168,3 +243,191 @@   , indexedVariablesScope = Nothing   , expensiveScope = False   }+++-- |+--   Arguments for 'setBreakpoints' request.+--+data SetBreakpointsArguments =+  SetBreakpointsArguments {+    sourceSetBreakpointsArguments         :: Source              -- ^The source location of the breakpoints; either source.path or source.reference must be specified. +  , breakpointsSetBreakpointsArguments    :: [SourceBreakpoint]  -- ^The code locations of the breakpoints.+  } deriving (Show, Read, Eq)+++-- |+--   A Source is a descriptor for source code. It is returned from the debug adapter as part of a StackFrame and it is used by clients when specifying breakpoints.+--+data Source =+  Source {+    nameSource             :: Maybe String  -- ^The short name of the source. Every source returned from the debug adapter has a name. When sending a source to the debug adapter this name is optional.+  , pathSource             :: String        -- ^The path of the source to be shown in the UI. It is only used to locate and load the content of the source if no sourceReference is specified (or its vaule is 0).+  , sourceReferenceSource  :: Maybe Int     -- ^If sourceReference > 0 the contents of the source must be retrieved through the SourceRequest (even if a path is specified). A sourceReference is only valid for a session, so it must not be used to persist a source.+  , origineSource          :: Maybe String     -- ^The (optional) origin of this source: possible values 'internal module', 'inlined content from source map', etc.+  } deriving (Show, Read, Eq)+++-- |+--+defaultSource :: Source+defaultSource = Source {+    nameSource             = Nothing+  , pathSource             = ""+  , sourceReferenceSource  = Nothing+  , origineSource          = Nothing+  }+++-- |+--   Properties of a breakpoint passed to the setBreakpoints request.+--+data SourceBreakpoint =+  SourceBreakpoint {+    lineSourceBreakpoint         :: Int           -- ^The source line of the breakpoint.+  , columnSourceBreakpoint       :: Maybe Int     -- ^An optional source column of the breakpoint. +  , conditionSourceBreakpoint    :: Maybe String  -- ^An optional expression for conditional breakpoints.+  , hitConditionSourceBreakpoint :: Maybe String  -- ^An optional expression that controls how many hits of the breakpoint are ignored. The backend is expected to interpret the expression as needed.+  } deriving (Show, Read, Eq)+++-- |+--   Response to "setBreakpoints" request.+--   Returned is information about each breakpoint created by this request.+--   This includes the actual code location and whether the breakpoint could be verified.+--   The breakpoints returned are in the same order as the elements of the 'breakpoints'+--   (or the deprecated 'lines') in the SetBreakpointsArguments.+--+data SetBreakpointsResponseBody =+  SetBreakpointsResponseBody {+    breakpointsSetBreakpointsResponseBody :: [Breakpoint]  -- ^Information about the breakpoints. The array elements are in the same order as the elements of the 'breakpoints' (or the deprecated 'lines') in the SetBreakpointsArguments.+  } deriving (Show, Read, Eq)+++-- |+--   Information about a Breakpoint created in setBreakpoints or setFunctionBreakpoints.+--+data Breakpoint =+  Breakpoint {+    idBreakpoint        :: Maybe Int -- ^An optional unique identifier for the breakpoint.+  , verifiedBreakpoint  :: Bool      -- ^If true breakpoint could be set (but not necessarily at the desired location).+  , messageBreakpoint   :: String    -- ^An optional message about the state of the breakpoint. This is shown to the user and can be used to explain why a breakpoint could not be verified.+  , sourceBreakpoint    :: Source    -- ^The source where the breakpoint is located.+  , lineBreakpoint      :: Int       -- ^The start line of the actual range covered by the breakpoint.+  , columnBreakpoint    :: Int       -- ^An optional start column of the actual range covered by the breakpoint.+  , endLineBreakpoint   :: Int       -- ^An optional end line of the actual range covered by the breakpoint.+  , endColumnBreakpoint :: Int       -- ^An optional end column of the actual range covered by the breakpoint. If no end line is given, then the end column is assumed to be in the start line.+  } deriving (Show, Read, Eq)+++-- |+--+defaultBreakpoint :: Breakpoint+defaultBreakpoint = Breakpoint {+    idBreakpoint        = Nothing+  , verifiedBreakpoint  = False+  , messageBreakpoint   = ""+  , sourceBreakpoint    = defaultSource+  , lineBreakpoint      = 0+  , columnBreakpoint    = 0+  , endLineBreakpoint   = 0+  , endColumnBreakpoint = 0+  }+++-- |+--   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)+++-- |+--   Event message for 'stopped' event type.+--   The event indicates that the execution of the debuggee has stopped due to some condition.+--   This can be caused by a break point previously set, a stepping action has completed, by executing a debugger statement etc.+--+data StoppedEventBody =+  StoppedEventBody {+    reasonStoppedEventBody            :: String  -- ^The reason for the event.For backward compatibility this string is shown in the UI if the 'description' attribute is missing (but it must not be translated).Values: 'step', 'breakpoint', 'exception', 'pause', 'entry', etc.+  , descriptionStoppedEventBody       :: String  -- ^The full reason for the event, e.g. 'Paused on exception'. This string is shown in the UI as is.+  , threadIdStoppedEventBody          :: Int     -- ^The thread which was stopped.+  , textStoppedEventBody              :: String  -- ^Additional information. E.g. if reason is 'exception', text contains the exception name. This string is shown in the UI. ++  {-|+     If allThreadsStopped is true, a debug adapter can announce that all threads have stopped.+     The client should use this information to enable that all threads can be expanded to access their stacktraces.+     If the attribute is missing or false, only the thread with the given threadId can be expanded.+  -}+  , allThreadsStoppedStoppedEventBody :: Bool+  } deriving (Show, Read, Eq)++-- |+--+defaultStoppedEventBody :: StoppedEventBody+defaultStoppedEventBody = StoppedEventBody {+    reasonStoppedEventBody = "breakpoint"+  , descriptionStoppedEventBody = ""+  , threadIdStoppedEventBody = 0+  , textStoppedEventBody = ""+  , allThreadsStoppedStoppedEventBody = True+  }+++-- |+--  Arguments for 'stackTrace' request.+--+data StackTraceArguments =+  StackTraceArguments {+    threadIdStackTraceArguments   :: Int        -- ^Retrieve the stacktrace for this thread.+  , startFrameStackTraceArguments :: Maybe Int  -- ^The index of the first frame to return; if omitted frames start at 0.+  , levelsStackTraceArguments     :: Int        -- ^The maximum number of frames to return. If levels is not specified or 0, all frames are returned.+  } deriving (Show, Read, Eq)+++-- |+--   Response to 'stackTrace' request.+--+data StackTraceBody =+  StackTraceBody {+    stackFramesStackTraceBody :: [StackFrame]  -- ^The frames of the stackframe. If the array has length zero, there are no stackframes available. This means that there is no location information available.+  , totalFramesStackTraceBody :: Int           -- ^The total number of frames available. +  } deriving (Show, Read, Eq)++-- |+--+defaultStackTraceBody :: StackTraceBody+defaultStackTraceBody = StackTraceBody {+    stackFramesStackTraceBody = []+  , totalFramesStackTraceBody = 0+  }++-- |+--   A Stackframe contains the source location.+--+data StackFrame =+  StackFrame {+    idStackFrame        :: Int     -- ^An identifier for the stack frame. It must be unique across all threads. This id can be used to retrieve the scopes of the frame with the 'scopesRequest' or to restart the execution of a stackframe.+  , nameStackFrame      :: String  -- ^The name of the stack frame, typically a method name.+  , sourceStackFrame    :: Source  -- ^The optional source of the frame.+  , lineStackFrame      :: Int     -- ^The line within the file of the frame. If source is null or doesn't exist, line is 0 and must be ignored.+  , columnStackFrame    :: Int     -- ^The column within the line. If source is null or doesn't exist, column is 0 and must be ignored. +  , endLineStackFrame   :: Int     -- ^An optional end line of the range covered by the stack frame.+  , endColumnStackFrame :: Int     -- ^An optional end column of the range covered by the stack frame.+  } deriving (Show, Read, Eq)+++-- |+--+defaultStackFrame = StackFrame {+    idStackFrame = 0+  , nameStackFrame = ""+  , sourceStackFrame = defaultSource+  , lineStackFrame = 0+  , columnStackFrame = 0+  , endLineStackFrame = 0+  , endColumnStackFrame = 0+}+