diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,8 @@ +20221127 ghci-dap-0.0.20.0 + * [MODIFY] hdx4vsc ISSUE#27 Feature request: support jumping into library + * [INFO] support ghc-9.4.3. + + 20221024 ghci-dap-0.0.19.0 * [INFO] support ghc-8.10.7. diff --git a/app-ghc-9.2/GHCi/GhcApiCompat.hs b/app-ghc-9.2/GHCi/GhcApiCompat.hs --- a/app-ghc-9.2/GHCi/GhcApiCompat.hs +++ b/app-ghc-9.2/GHCi/GhcApiCompat.hs @@ -18,6 +18,7 @@ , module GHC.Unit.Module.ModSummary , module GHC.Driver.Env.Types , module GHC.Runtime.Context + , module GHC.Types.FieldLabel , CMC.catch ) where @@ -40,4 +41,5 @@ import GHC.Unit.Module.ModSummary import GHC.Driver.Env.Types import GHC.Runtime.Context +import GHC.Types.FieldLabel import qualified Control.Monad.Catch as CMC diff --git a/app-ghc-9.4/GHCi/GhcApiCompat.hs b/app-ghc-9.4/GHCi/GhcApiCompat.hs --- a/app-ghc-9.4/GHCi/GhcApiCompat.hs +++ b/app-ghc-9.4/GHCi/GhcApiCompat.hs @@ -19,6 +19,7 @@ , module GHC.Driver.Env.Types , module GHC.Runtime.Context , module GHC.Types.BreakInfo + , module GHC.Types.FieldLabel , CMC.catch , pprTypeForUser , ic_rn_gbl_env @@ -46,6 +47,7 @@ import GHC.Types.BreakInfo import GHC.Core.TyCo.Ppr import GHC.Core.Type +import GHC.Types.FieldLabel import qualified Control.Monad.Catch as CMC -- | diff --git a/app/GHCi/DAP/Command.hs b/app/GHCi/DAP/Command.hs --- a/app/GHCi/DAP/Command.hs +++ b/app/GHCi/DAP/Command.hs @@ -12,7 +12,9 @@ import Control.Concurrent import Control.Monad +import qualified Control.Monad.Catch as E import System.Console.Haskeline +import System.Directory import qualified Data.Map as M import qualified Data.List as L @@ -21,6 +23,10 @@ import GHCi.DAP.Utility import qualified Haskell.DAP as D +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Data.StringBuffer as SB (lexemeToString, len) +#else +#endif -- | -- @@ -39,6 +45,7 @@ , ("dap-continue", Gi.keepGoing dapContinueCmd, noCompletion) , ("dap-next", Gi.keepGoing nextCmd, noCompletion) , ("dap-step-in", Gi.keepGoing stepInCmd, noCompletion) + , ("dap-source", Gi.keepGoing sourceCmd, noCompletion) ] where mkCmd (n,a,c) = Gi.Command { @@ -457,14 +464,36 @@ then hists else resume2stackframe r : hists let traceWithId = setFrameIdx 0 traces + traceWithId' <- liftIO $ mapM convertToAbs traceWithId return $ Right D.defaultStackTraceResponseBody { - D.stackFramesStackTraceResponseBody = traceWithId - , D.totalFramesStackTraceResponseBody = length traceWithId + D.stackFramesStackTraceResponseBody = traceWithId' + , D.totalFramesStackTraceResponseBody = length traceWithId' } -- | -- + convertToAbs :: D.StackFrame -> IO D.StackFrame + convertToAbs sf@D.StackFrame{D.sourceStackFrame=ssf} + | D.pathSource ssf == _STACK_FRAME_UNHELPFULL_SPAN = return sf + | otherwise = E.catch (pathToAbs sf ssf) (constSF sf) + + -- | + -- + pathToAbs :: D.StackFrame -> D.Source -> IO D.StackFrame + pathToAbs sf ssf = do + ps <- canonicalizePath $ D.pathSource ssf + return sf{D.sourceStackFrame=ssf{D.pathSource = ps}} + + -- | + -- + constSF :: D.StackFrame -> E.SomeException -> IO D.StackFrame + constSF sf e = do + putStrLn $ show InfoLogLevel ++ show e + return sf + + -- | + -- resumeHist2stackFrame :: G.History -> Gi.GHCi D.StackFrame resumeHist2stackFrame hist= do span <- G.getHistorySpan hist @@ -509,7 +538,7 @@ genStackFrame (G.UnhelpfulSpan _) name = D.defaultStackFrame { D.idStackFrame = 0 , D.nameStackFrame = name - , D.sourceStackFrame = D.defaultSource {D.pathSource = "UnhelpfulSpan"} + , D.sourceStackFrame = D.defaultSource {D.pathSource = _STACK_FRAME_UNHELPFULL_SPAN} , D.lineStackFrame = 0 , D.columnStackFrame = 0 , D.endLineStackFrame = 0 @@ -601,7 +630,7 @@ where contName :: GAC.GreName -> [G.Name] -> [G.Name] contName (GAC.NormalGreName n) xs = n:xs - contName (GAC.FieldGreName _) xs = xs + contName (GAC.FieldGreName n) xs = GAC.fieldLabelPrintableName n:xs #elif __GLASGOW_HASKELL__ >= 902 -- | -- @@ -616,7 +645,7 @@ where contName :: GAC.GreName -> [G.Name] -> [G.Name] contName (GAC.NormalGreName n) xs = n:xs - contName (GAC.FieldGreName _) xs = xs + contName (GAC.FieldGreName n) xs = GAC.fieldLabelPrintableName n:xs #else -- | -- @@ -718,8 +747,14 @@ ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState ctx <- liftIO $ readMVar ctxMVar let isInspect = isInspectVariableDAPContext ctx - mapM (tyThing2Var isInspect) bindings + -- + -- ref: https://gitlab.haskell.org/ghc/ghc/-/issues/19394 + -- ignore console messages. + -- : ^^ Could not load 'ghczmprim_GHCziPrim_seq_closure', dependency unresolved. See top entry above. + -- + vars <- mapM (tyThing2Var isInspect) bindings + return vars -- | -- @@ -1092,3 +1127,41 @@ Right <$> genStoppedEventBody "step" +------------------------------------------------------------------------------------------------ +-- DAP Command :dap-source +------------------------------------------------------------------------------------------------ +-- | +-- +sourceCmd :: String -> Gi.GHCi () +sourceCmd argsStr = flip gcatch errHdl $ do + decodeDAP argsStr + >>= sourceCmd_ + >>= printDAP + +-- | +-- +sourceCmd_ :: D.SourceRequestArguments + -> Gi.GHCi (Either String D.SourceResponseBody) + +#if __GLASGOW_HASKELL__ >= 900 +sourceCmd_ args = do + modSums <- Gi.getLoadedModules + case D.sourceSourceRequestArguments args of + Nothing -> throwError " deprecated data: sourceReference property in SourceRequest is not supported" + Just srcInfo -> do + let srcPath = D.pathSource srcInfo + modPaths = map takeModPath modSums + summary = L.find (\sum -> G.ms_hspp_file sum == srcPath) modSums + case summary of + Nothing -> throwError $ " loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths + Just summary -> do + case G.ms_hspp_buf summary of + Nothing -> throwError $ " loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths + Just strBuf -> do + let content = SB.lexemeToString strBuf (SB.len strBuf) + return $ Right D.defaultSourceResponseBody { + D.contentSourceResponseBody = content + } +#else +sourceCmd_ _ = throwError " supported from ghc9." +#endif diff --git a/app/GHCi/DAP/Constant.hs b/app/GHCi/DAP/Constant.hs --- a/app/GHCi/DAP/Constant.hs +++ b/app/GHCi/DAP/Constant.hs @@ -31,3 +31,9 @@ -- _EVALUATE_INSPECT_DEPTH :: Int _EVALUATE_INSPECT_DEPTH = 1000 + +-- | +-- +_STACK_FRAME_UNHELPFULL_SPAN :: String +_STACK_FRAME_UNHELPFULL_SPAN = "UnhelpfulSpan" + diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -11,13 +11,14 @@ import Paths_ghci_dap (version) import Data.Version +import System.IO (stderr, hPutStrLn) -- | -- Main -- main :: IO () main = do - putStrLn $ "[DAP][INFO] start ghci-dap-" ++ showVersion version ++ "." + hPutStrLn stderr $ "[DAP][INFO] start ghci-dap-" ++ showVersion version ++ "." mvarCtx <- newMVar defaultDAPContext diff --git a/ghci-dap.cabal b/ghci-dap.cabal --- a/ghci-dap.cabal +++ b/ghci-dap.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: ghci-dap -version: 0.0.19.0 +version: 0.0.20.0 synopsis: ghci-dap is a GHCi having DAP interface. description: Please see README.md category: Development @@ -45,7 +45,7 @@ , ghc-prim , ghci , haskeline - , haskell-dap >=0.0.15.0 + , haskell-dap >=0.0.16.0 , process , text , time @@ -84,7 +84,7 @@ , ghci , ghci-dap , haskeline - , haskell-dap >=0.0.15.0 + , haskell-dap >=0.0.16.0 , process , text , time @@ -150,4 +150,5 @@ else build-depends: unix + -- ghc-options: -dynamic-too default-language: Haskell2010