diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,36 @@ # Revision history for haskell-debugger +## 0.13.0.0 -- 2026-04-24 + +Features: + +* Launch the external-interpreter directly in User's Terminal. That is, VSCode + terminal will run the external interpreter, which is evaluating the debuggee + directly, directly (rather than a proxy program). + * When using the internal interpreter, falls back to running `hdb proxy`. +* Add support for `import Module` statements at the debug REPL. +* Add [logpoints](https://code.visualstudio.com/docs/debugtest/debugging#_logpoints) support. +* Support for nightly GHC 9.15, leveraging external interpreter commands. + +Bug fixes: +* Fix: Import failed where depended-upon package was incorrectly considered hidden +* Fix: Respond cleanly to DAP client with ErrorResponse on exceptions, rather than crashing the session. +* Fix: terminate/disconnect/terminated wasn't following DAP properly, resulting in premature exiting crashes +* Fix: Debugger.View.Class cannot be found in certain multi-repl sessions +* Fix: Make custom DebugViews instances work for `newtypes` +* Fix: Display more unevaluatable closures as `` rather than as thunks `_` +* Fix: Inherit the language extensions at any given breakpoint source to the REPL +* Fix: Don't print certain evaluation results in duplicate +* Fix: Set scopeExpensive=true for Module and Global + +Additionally, the debugger internals and the testsuite were considerably +refactored and improved, paving the way for better, faster changes, with more +confidence. + +## 0.12.3.0 -- 2026-03-11 + +* Updated extension logo to be Haskell's logo + ## 0.12.2.0 -- 2026-03-09 * Bug fixes and improved progress reporting diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -179,10 +179,22 @@ nix-build ``` -## Testing +## Testing and Debugging ``` -cd test/integration-tests -make GHC=/path/to/recent/ghc \ - DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/ghc-9.14 exe:hdb) +# Main testsuite (includes the golden tests, unit tests, and the integration +# tests that used to be run via the NodeJS @vscode-debugadapter-testsupport@ +# library). +cabal run haskell-debugger-test ``` + +### Debugging the debugger with the debugger + +1. Run the debugger (e.g. through VSCode) with `entryFile: hdb/Main.hs` and + arguments `entryArgs: [server, --port, 12345]`. This will start the debugger + executable on port 12345 through the debugger. + +2. Using VSCode, setup the launch.json for the project you want to test the + debugger with `debugServer: 12345`. This will tell VSCode to connect to this + port for the DAP server. This should trigger the breakpoint you set on the + debugger in step (1). diff --git a/haskell-debugger-view/CHANGELOG.md b/haskell-debugger-view/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/haskell-debugger-view/CHANGELOG.md @@ -0,0 +1,20 @@ +# Revision history for haskell-debugger-view + +## 0.2.1.0 -- 2026-02-24 + +* Add `DebugView` instance for `SomeException` +* Documentation fixes + +## 0.2.0.0 -- 2026-01-05 + +* Add support for more complex debug visualizations using the Program abstraction + * API change: `debugValue` and `debugFields` now return `Program`-wrapped + values, rather than `VarFields/VarValue` directly. +* Introduce new functions `isThunk` and `ifP` for conditional debugging behavior +* Enhance list visualization to show up to 50 forced elements +* Add improved handling for lazy values in debug views +* Update documentation and examples for custom DebugView instances + +## 0.1.0.0 -- 2025-11-18 + +* First version. Released on an unsuspecting world. diff --git a/haskell-debugger-view/LICENSE b/haskell-debugger-view/LICENSE new file mode 100644 --- /dev/null +++ b/haskell-debugger-view/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Rodrigo Mesquita + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskell-debugger-view/haskell-debugger-view.cabal b/haskell-debugger-view/haskell-debugger-view.cabal new file mode 100644 --- /dev/null +++ b/haskell-debugger-view/haskell-debugger-view.cabal @@ -0,0 +1,45 @@ +cabal-version: 3.12 +name: haskell-debugger-view +version: 0.2.1.0 +license: BSD-3-Clause +author: Matthew Pickering, Rodrigo Mesquita +maintainer: matthewtpickering@gmail.com, rodrigo@well-typed.com +build-type: Simple +extra-doc-files: CHANGELOG.md +category: Development +synopsis: + Custom debug visualization instances for @haskell-debugger@ +description: + This package provides a class to implement custom debug visualization + instances for user-defined datatypes, which will be discovered and used by + @haskell-debugger@ when debugging a program. Additionally, it provides a + handful of built-in custom visualizations, such as for @String@ and @IntMap@. + The custom debug visualizations are displayed in the editor when inspecting + a variable or evaluation result. The @'DebugView'@ class is the class for + which an instance must be provided, and allows one to customize what is + displayed inline and what fields are available when expanding it. + See the haddocks of @'GHC.Debugger.View.Class'@ for further information. + +common warnings + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/well-typed/haskell-debugger + subdir: haskell-debugger-view + +library + import: warnings + -- If you add a module here make sure to also add this module to the list + -- of modules that we attempt to load when haskell-debug-view is not + -- dependend upon transitively, in GHC.Debugger.Session.Builtin + exposed-modules: GHC.Debugger.View.Class + GHC.Debugger.View.Containers + GHC.Debugger.View.Text + GHC.Debugger.View.ByteString + build-depends: base >= 4.22 && < 5, + containers >= 0.7 && < 0.9, + text >= 2.1 && < 2.3, + bytestring >= 0.12.1 && < 0.13, + hs-source-dirs: src + default-language: GHC2021 diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger -version: 0.12.2.0 +version: 0.13.0.0 synopsis: A step-through debugger for GHC Haskell @@ -9,17 +9,17 @@ programs and can act as a Debug Adapter Protocol (DAP) server in the @server@ mode for debugging Haskell programs. - + The Debug Adapter is implemented on top of the @haskell-debugger@ library which defines the primitive debugging capabilities. These debugger features are implemented by managing a GHC session and debugging it through the GHC API. - + The @hdb@ is transparently compatible with most projects because it uses @hie-bios@ to figure out the right flags to invoke GHC with. - + Additional information can be found [in the README](https://github.com/well-typed/haskell-debugger). license: BSD-3-Clause @@ -37,9 +37,21 @@ haskell-debugger-view/src/GHC/Debugger/View/Containers.hs haskell-debugger-view/src/GHC/Debugger/View/Text.hs haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs + haskell-debugger-view/haskell-debugger-view.cabal + haskell-debugger-view/LICENSE + haskell-debugger-view/CHANGELOG.md -- Should probably be extra extra-files but that requires cabal 3.14 test/golden/**/*.hs + test/golden/**/*.cabal + test/golden/**/*.yaml + test/golden/**/*.project + + test/integration/**/*.hs + test/integration/**/*.cabal + test/integration/**/*.yaml + test/integration/**/*.project + test/golden/**/*.hdb-stdin test/golden/**/*.hdb-stdout test/golden/**/*.hdb-test @@ -89,13 +101,22 @@ GHC.Debugger.Runtime.Thread.Stack, GHC.Debugger.Runtime.Thread.Map, + GHC.Debugger.Runtime.Interpreter.Custom, + GHC.Debugger.Monad, GHC.Debugger.Utils, + GHC.Debugger.Utils.Orphans, GHC.Debugger.Session, GHC.Debugger.Session.Builtin, + GHC.Debugger.Session.Interactive, GHC.Debugger.Interface.Messages - -- other-modules: + + if impl(ghc >= 9.15) + exposed-modules: + GHC.Debugger.Runtime.Interpreter + + default-extensions: CPP build-depends: base >= 4.22 && < 5, ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16, @@ -113,17 +134,20 @@ exceptions >= 0.10.9 && < 0.11, bytestring >= 0.12.1 && < 0.13, async >= 2.2.6 && < 2.3, + network >= 3.2.8, cryptohash-sha1 >= 0.11.101.0 && < 0.12, base16-bytestring >= 1.0.2.0 && < 1.1, aeson >= 2.2.3 && < 2.3, - hie-bios >= 0.15 && < 0.19, + hie-bios >= 0.15 && < 0.20, file-embed >= 0.0.16 && < 0.1, attoparsec >= 0.13 && < 0.15, time >= 1.14 && < 2, text >= 2.1 && < 2.3, + retry >= 0.9 && < 1, co-log-core >= 0.3.2.5 && < 0.4, - haskell-debugger-view >= 0.2 && < 1.0 + haskell-debugger-view >= 0.2 && < 1.0, + ghc-stack-annotations >=0.1 && <0.2, if !os(windows) build-depends: unix >= 2.8.6 && < 2.9, @@ -143,6 +167,7 @@ Development.Debug.Adapter.Interface, Development.Debug.Adapter.Output, Development.Debug.Adapter.Exit, + Development.Debug.Adapter.Exit.Helpers, Development.Debug.Adapter.Handles, Development.Debug.Adapter, @@ -177,10 +202,13 @@ network-run >= 0.4.4, async >= 2.2.5 && < 2.3, text >= 2.1 && < 2.3, - dap >= 0.4 && < 0.5, + dap >= 0.5 && < 0.6, haskeline >= 0.8 && < 1, - optparse-applicative >= 0.18 && < 0.20 + optparse-applicative >= 0.18 && < 0.20, + uuid >= 1.3 && < 1.4, + ghc-stack-annotations >=0.1 && <0.2, + hs-source-dirs: hdb default-language: GHC2021 default-extensions: CPP @@ -195,18 +223,41 @@ type: exitcode-stdio-1.0 hs-source-dirs: test/haskell/ main-is: Main.hs - other-modules: Test.DAP.RunInTerminal, Test.DAP, Test.Utils + other-modules: Test.DAP, + Test.DAP.Init, + Test.DAP.Messages, + Test.DAP.Messages.Parser, + Test.DAP.Orphans, + Test.Utils, + + Test.Integration.RunInTerminal, + Test.Integration.Scopes, + Test.Integration.LogMessage, + Test.Integration.Persistent, + Test.Integration.Basic, + Test.Integration.Exceptions, + Test.Integration.MultiMain, + Test.Integration.MultiHomeUnit, + Test.Integration.Variables, + Test.Integration.StepOut, + Test.Integration.Stdout, + Test.Integration.Conditional, + Test.Integration.Evaluate, + Test.Integration.StackTrace build-depends: base >=4.14, + async, haskell-debugger, bytestring, text, containers, + directory, filepath, process, temporary >= 1.3, + mtl, unordered-containers, - aeson-pretty >= 0.8.10, async >= 2.2.5, + aeson-pretty >= 0.8.10, dap, network, aeson, network-run, random >= 1.3.1, @@ -214,6 +265,13 @@ tasty-golden >= 2.3.5, tasty-hunit >= 0.10.2, tasty-expected-failure >= 0.12.3, - regex >= 1.1 + regex >= 1.1, + exceptions, + retry, + stm >= 2.5.3.1, + build-tool-depends: haskell-debugger:hdb ghc-options: -threaded + -- TODO: Investigate apparent race condition on windows + if !os(windows) + ghc-options: -rtsopts "-with-rtsopts=-N" diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -3,9 +3,6 @@ TypeApplications, ScopedTypeVariables, BangPatterns #-} module GHC.Debugger where -import System.Exit -import Control.Monad.IO.Class - import GHC.Debugger.Breakpoint import GHC.Debugger.Run import GHC.Debugger.Stopped @@ -22,21 +19,18 @@ execute = \case ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp) - SetBreakpoint{brk, hitCount, condition} -> - DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition) - DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled + SetBreakpoint{brk, hitCount, condition, logMessage} -> + DidSetBreakpoint <$> setBreakpoint brk (condBreakEnableStatus hitCount condition) (maybe BreakpointStop (BreakpointLogAndResume . logMessageExpression) logMessage) + DelBreakpoint bp -> DidRemoveBreakpoint <$> setBreakpoint bp BreakpointDisabled BreakpointStop GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp GetThreads -> GotThreads <$> getThreads GetStacktrace i -> GotStacktrace <$> getStacktrace i GetScopes threadId frameIx -> GotScopes <$> getScopes threadId frameIx GetVariables threadId frameIx varRef -> GotVariables <$> getVariables threadId frameIx varRef GetExceptionInfo threadId -> GotExceptionInfo <$> getExceptionInfo threadId - DoEval exp_s -> DidEval <$> doEval exp_s + DoEval exp_s -> DidEval <$> doEvalCommand exp_s DoContinue -> DidContinue <$> doContinue DoSingleStep -> DidStep <$> doSingleStep DoStepOut -> DidStep <$> doStepOut DoStepLocal -> DidStep <$> doLocalStep DebugExecution { entryPoint, entryFile, runArgs } -> DidExec <$> debugExecution entryFile entryPoint runArgs - TerminateProcess -> liftIO $ do - -- Terminate! - exitWith ExitSuccess diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bits (xor) +import Data.List (intercalate) import Data.IORef import System.Directory import System.FilePath @@ -66,12 +67,12 @@ getBreakpointsAt _ = error "unexpected getbreakpoints without ModuleBreak" -- | Set a breakpoint in this session -setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound -setBreakpoint bp BreakpointAfterCountCond{} = do +setBreakpoint :: Breakpoint -> BreakpointStatus -> BreakpointAction -> Debugger BreakFound +setBreakpoint bp BreakpointAfterCountCond{} _action = do logSDoc Logger.Warning $ text $ "Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " ++ show bp return BreakNotFound -setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do +setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status action = do mmodl <- getModuleByPath path case mmodl of Left e -> do @@ -83,13 +84,17 @@ Just (bix, spn) -> do let bid = BreakpointId { bi_tick_mod = ms_mod modl , bi_tick_index = bix } - (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind + binfo = BreakpointInfo + { bpInfoStatus = bp_status + , bpInfoKind = ModuleBreakpointKind + , bpInfoAction = action} + (changed, ibis) <- registerBreakpoint bid binfo return $ BreakFound { changed = changed , sourceSpan = realSrcSpanToSourceSpan spn , breakId = ibis } -setBreakpoint FunctionBreak{function} bp_status = do +setBreakpoint FunctionBreak{function} bp_status action = do logger <- getLogger resolveFunctionBreakpoint function >>= \case Left e -> do @@ -101,7 +106,11 @@ applyBreak (bix, spn) = do let bid = BreakpointId { bi_tick_mod = modl , bi_tick_index = bix } - (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind + binfo = BreakpointInfo + { bpInfoStatus = bp_status + , bpInfoKind = FunctionBreakpointKind + , bpInfoAction = action} + (changed, ibis) <- registerBreakpoint bid binfo return $ BreakFound { changed = changed , sourceSpan = realSrcSpanToSourceSpan spn @@ -115,7 +124,8 @@ bs -> do liftIO $ logOutput logger (text $ "Ambiguous breakpoint found by name " ++ function ++ ": " ++ show bs ++ ". Setting breakpoints in all...") ManyBreaksFound <$> mapM applyBreak bs -setBreakpoint exception_bp bp_status = do +-- The assert can be removed once we have a way to register actions for exception breakpoints. +setBreakpoint exception_bp bp_status action = assert (action == BreakpointStop) $ do let ch_opt | BreakpointDisabled <- bp_status = gopt_unset | otherwise @@ -142,8 +152,8 @@ -- 'BreakpointStatus' being set. -- -- Returns @True@ when the breakpoint status is changed. -registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger (Bool, [GHC.InternalBreakpointId]) -registerBreakpoint bp status kind = do +registerBreakpoint :: GHC.BreakpointId -> BreakpointInfo -> Debugger (Bool, [GHC.InternalBreakpointId]) +registerBreakpoint bp info@BreakpointInfo{bpInfoStatus = status} = do -- Set breakpoint in GHC session let breakpoint_count = breakpointStatusInt status @@ -162,12 +172,12 @@ -- Enabling the breakpoint: _ -> case BM.lookup ibi brksMap of - Just (status', _kind) - | status' == status + Just info' + | info' == info -> -- Nothing changed, OK (brksMap, False) _ -> -- Else, insert - (BM.insert ibi (status, kind) brksMap, True) + (BM.insert ibi info brksMap, True) return (any id changed, internal_break_ids) @@ -196,7 +206,7 @@ Nothing -> do return [ ibi - | (ibi, (status, kind)) <- BM.toList bm + | (ibi, BreakpointInfo{bpInfoStatus=status, bpInfoKind=kind}) <- BM.toList bm -- Keep only function breakpoints in this case , FunctionBreakpointKind == kind , assert (status > BreakpointDisabled) True @@ -231,6 +241,39 @@ (Just i, Nothing) -> BreakpointAfterCount i (Nothing, Just c) -> BreakpointWhenCond c (Just i, Just c) -> BreakpointAfterCountCond i c + + +-- | @logMessageExpression "foo = {show foo}" = "putStrLn (concat [\"foo = \", show foo])"@ +-- +-- Braces are preserved if escaped with a backslash. Some unescaped braces are +-- fine: opening braces in antiquotations and closing braces outside of them. +logMessageExpression :: String -> String +logMessageExpression tmpl = apply "Prelude.putStrLn" $ apply "Prelude.concat" $ parts + where + apply f x = f ++ " ( " ++ x ++ " ) " + parts = listOf $ map renderPart (parseQC [] tmpl) + listOf xs = intercalate ": " . (++ ["[]"]) $ xs + renderPart (Literal s) = show s + renderPart (AntiQuote e) = apply "" e + +-- Taken from interpolatedstring-perl6 package +data StringPart = Literal String | AntiQuote String deriving Show + +unQC :: String -> String -> [StringPart] +unQC a [] = [Literal (reverse a)] +unQC a ('\\':x:xs) = unQC (x:a) xs +unQC a ('\\':[]) = unQC ('\\':a) [] +unQC a ('}':xs) = AntiQuote (reverse a) : parseQC [] xs +unQC a (x:xs) = unQC (x:a) xs + +parseQC :: String -> String -> [StringPart] +parseQC a [] = [Literal (reverse a)] +parseQC a ('\\':'\\':xs) = parseQC ('\\':a) xs +parseQC a ('\\':'{':xs) = parseQC ('{':a) xs +parseQC a ('\\':[]) = parseQC ('\\':a) [] +parseQC a ('{':xs) = Literal (reverse a) : unQC [] xs +parseQC a (x:xs) = parseQC (x:a) xs + -- | Get a 'ModSummary' of a loaded module given its 'FilePath' getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary) diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -14,6 +14,8 @@ import qualified GHC.Utils.Outputable as GHC import GHC.Debugger.Runtime.Term.Key +import Data.Binary (Binary) +import qualified GHC.Stack as Stack -------------------------------------------------------------------------------- -- Commands @@ -28,6 +30,8 @@ -- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@) , condition :: Maybe String -- ^ Stop if condition evalutes to True + , logMessage :: Maybe String + -- ^ Log only if @condition@ (and @hitCondition@ when supported) are @True@. } -- | Delete a breakpoint on a given function, or module by line number @@ -85,9 +89,6 @@ -- Haskell function arguments. | DebugExecution { entryPoint :: EntryPoint, entryFile :: FilePath, runArgs :: [String] } - -- | Terminate haskell-debugger and exit - | TerminateProcess - -- | An entry point for program execution. data EntryPoint = MainEntry { mainName :: Maybe String } | FunctionEntry { fnName :: String } deriving (Show) @@ -211,6 +212,16 @@ , endCol = 0 } +srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan +srcLocToSourceSpan srcLoc = + SourceSpan + { file = Stack.srcLocFile srcLoc + , startLine = Stack.srcLocStartLine srcLoc + , endLine = Stack.srcLocEndLine srcLoc + , startCol = Stack.srcLocStartCol srcLoc + , endCol = Stack.srcLocEndCol srcLoc + } + -------------------------------------------------------------------------------- -- Responses -------------------------------------------------------------------------------- @@ -261,11 +272,14 @@ -- find the proper remote 'ThreadId' corresponding to this numeric -- identifier, lookup the 'remoteThreadIntRef' in the 'ThreadMap' } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Binary) +data SourceKind = IsExpr | IsStmt + data EvalResult = EvalCompleted { resultVal :: String , resultType :: String + , resultSourceKind :: Maybe SourceKind , resultStructureRef :: VariableReference -- ^ A structured representation of the result of evaluating -- the expression given as a "virtual" 'VariableReference' @@ -307,6 +321,7 @@ , exceptionInfoFullTypeName :: String , exceptionInfoMessage :: String , exceptionInfoContext :: Maybe String + , exceptionInfoSourceSpan :: Maybe SourceSpan , exceptionInfoInner :: [ExceptionInfo] } deriving (Show) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -19,13 +19,14 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad -import Control.Monad.Catch +import Control.Monad.Catch as MC import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function import Data.Functor.Contravariant import Data.IORef import Data.Maybe +import qualified Data.Set as Set import Data.Version (makeVersion, showVersion) import Prelude hiding (mod) #ifdef MIN_VERSION_unix @@ -34,11 +35,15 @@ import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty +import Network.Socket hiding (Debug) +import System.Process.Internals (mkProcessHandle) +import Text.Read (readMaybe) import GHC import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC import GHC.Driver.Env import GHC.Driver.Monad @@ -48,10 +53,12 @@ import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Ppr +import GHC.Driver.Session (parseDynamicFlagsCmdLine) import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Loader as GHC +import GHC.Runtime.Context as GHCi import GHC.Types.Error import GHC.Types.PkgQual import GHC.Types.SourceError @@ -68,6 +75,7 @@ import GHC.Debugger.Interface.Messages import GHC.Debugger.Session import GHC.Debugger.Session.Builtin +import GHC.Debugger.Session.Interactive import GHC.Debugger.Runtime.Compile.Cache import GHC.Debugger.Utils import qualified GHC.Debugger.Breakpoint.Map as BM @@ -76,6 +84,16 @@ import Colog.Core as Logger import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache) +import GHCi.Message (mkPipeFromHandles) +import System.IO (hGetLine, IOMode(..)) +import qualified GHC.Linker.Loader as Loader +import GHC.Stack.Annotation +import GHC.Platform.Ways +#if MIN_VERSION_ghc(9,15,0) +import GHC.Data.FastString.Env (emptyFsEnv) +#endif +import GHC.Unit.Home.Graph +import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a } @@ -83,11 +101,18 @@ , MonadThrow, MonadCatch, MonadMask , GHC.HasDynFlags, MonadReader DebuggerState ) +data BreakpointInfo = BreakpointInfo + { bpInfoStatus :: !BreakpointStatus + , bpInfoKind :: !BreakpointKind + , bpInfoAction :: !BreakpointAction + } + deriving (Eq,Show) + -- | State required to run the debugger. -- -- - Keep track of active breakpoints to easily unset them all. data DebuggerState = DebuggerState - { activeBreakpoints :: IORef (BM.BreakpointMap (BreakpointStatus, BreakpointKind)) + { activeBreakpoints :: IORef (BM.BreakpointMap BreakpointInfo) -- ^ Maps a 'InternalBreakpointId' in Trie representation (map of Module to map of Int) to the -- 'BreakpointStatus' it was activated with. @@ -150,6 +175,18 @@ instance Outputable BreakpointStatus where ppr = text . show +-- | What to do when a breakpoint is enabled +data BreakpointAction + -- | Evaluation is stopped, typical behaviour + = BreakpointStop + {- | A log message is printed and then evaluation resumes. + The @String@ is an expression that takes care of interpolation and printing the log message. + -} + | BreakpointLogAndResume String + deriving (Eq, Ord, Show) + +instance Outputable BreakpointAction where ppr = text . show + -------------------------------------------------------------------------------- -- Operations -------------------------------------------------------------------------------- @@ -159,9 +196,13 @@ { supportsANSIStyling :: Bool , supportsANSIHyperlinks :: Bool , preferInternalInterpreter :: Bool - , externalInterpreterStdinStream :: StdStream - -- ^ How to determine the stdin of the external interpreter running the - -- debuggee. If not using the external interpreter this field is unused. + , externalInterpreterCustomProc :: Either StdStream PortNumber + -- ^ Right: use a custom given existing process for the external + -- interpreter listening at given port. (This is used when we want to + -- launch the external interpreter attached to a user's terminal). + -- + -- Left: we launch our own external interpreter process through + -- GHC's spawnIServ using the given StdStream as the stdin. } -- | Run a 'Debugger' action on a session constructed from a given GHC invocation. @@ -177,15 +218,21 @@ -> RunDebuggerSettings -- ^ Other debugger run settings -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation -> IO a -runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do +runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = annotateCallStackIO $ do let ghcLog = liftLogIO l :: LogAction Ghc DebuggerLog let dbgLog = liftLogIO l :: LogAction Debugger DebuggerLog thisProg <- getExecutablePath let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' - GHC.runGhc (Just libdir) $ do + GHC.runGhc (Just libdir) $ + flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter] + do #ifdef MIN_VERSION_unix -- Workaround #4162 + -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it. _ <- liftIO $ installHandler sigINT Default Nothing + _ <- liftIO $ installHandler sigQUIT Default Nothing + _ <- liftIO $ installHandler sigTERM Default Nothing + _ <- liftIO $ installHandler sigHUP Default Nothing #endif dflags0 <- GHC.getSessionDynFlags let dflags1 = dflags0 @@ -236,7 +283,7 @@ -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be -- reverted) (dflags2, fileish_args, warns) - <- parseDynamicFlags logger dflags1 (map noLoc extraGhcArgs) + <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs) liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) forM_ fileish_args $ \fish_arg -> liftIO $ do GHC.logMsg logger MCOutput noSrcSpan $ text "Ignoring extraGhcArg which isn't a recognized flag:" <+> text (unLoc fish_arg) @@ -246,29 +293,43 @@ -- Make sure to override the function which creates the external -- interpreter, because we need to keep track of the standard handles iserv_handles <- liftIO newEmptyMVar - modifySession $ \h -> h - { hsc_hooks = (hsc_hooks h) - { createIservProcessHook = Just $ \cp -> do - -- See Note [External interpreter buffering] - (_, Just o, Just e, ph) <- - createProcess cp - { std_in = conf.externalInterpreterStdinStream - , std_out = CreatePipe - , std_err = CreatePipe - -- Override executable path - -- See Note [Custom external interpreter] + case conf.externalInterpreterCustomProc of + -- Left: GHC will launch the external interpreter itself on demand if + -- using external interpreter, and we just provide the stdin stream + Left givenStdStream -> + modifySession $ \h -> h + { hsc_hooks = (hsc_hooks h) + { createIservProcessHook = Just $ \cp -> do + -- See Note [External interpreter buffering] + (_, Just o, Just e, ph) <- + createProcess cp + { std_in = givenStdStream + , std_out = CreatePipe + , std_err = CreatePipe + -- Override executable path + -- See Note [Custom external interpreter] #if MIN_VERSION_ghc(9,15,0) #else - , cmdspec = case cmdspec cp of - ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws - RawCommand _fp args -> RawCommand thisProg args + , cmdspec = case cmdspec cp of + ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws + RawCommand _fp args -> RawCommand thisProg args #endif - } - putMVar iserv_handles (o, e) - return ph + } + putMVar iserv_handles (o, e) + return ph + } } - } + -- Right: we supply our custom external interpreter process, which is + -- already running and connected to the user's terminal. + Right port -> do + extInterp <- liftIO + $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process" + $ extInterpFromTerminalProcess port + modifySession $ \h -> h + { hsc_interp = Just extInterp -- set it directly! + } + let externalInterpFwdThread :: IO () externalInterpFwdThread = when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ do @@ -361,15 +422,20 @@ when (GHC.failed success) $ liftIO $ throwM DebuggerFailedToLoad + -- See Note [Must explicitly expose module graph units] + setExposedInUnit interactiveGhcDebuggerUnitId (graphUnits final_mod_graph) + -- Set interactive context to import all loaded modules let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" -- dbgView should always be available, either because we manually loaded it -- or because it's in the transitive closure. + hug <- hsc_HUG <$> getSession let dbgViewImps - -- Using in-memory hs-dbg-view. It's a home-unit, so refer to it directly - | hdv_uid == hsDebuggerViewInMemoryUnitId + -- If hs-dbg-view is a home-unit, refer to it directly + -- See Note [Do not package-qualify imports for home units] + | memberHugUnitId hdv_uid hug = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames - -- It's available in a unit in the transitive closure. Resolve it. + -- It's available in an exposed unit in the transitive closure. Resolve it | otherwise = map (\mn -> GHC.IIDecl (GHC.simpleImportDecl mn) @@ -396,17 +462,232 @@ hscInterp <$> GHC.getSession >>= \interp -> liftIO $ evalIO interp setBufferings + noPrint <- defineNoPrint + modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint}) + runReaderT action =<< initialDebuggerState dbgLog (if loadedBuiltinModNames == [] then Nothing else Just hdv_uid) - fwd_thr <- liftIO $ async (void externalInterpFwdThread) - liftIO $ link fwd_thr - mainGhcThread + case conf.externalInterpreterCustomProc of + Left _ -> do + -- We launched the external interpreter ourselves, so forward its output to the logger. + withUnliftGhc $ \ unlift -> do + withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do + liftIO $ link fwd_thr + unlift mainGhcThread + Right _ -> + -- Ext interp is running in user terminal, no need to forward output to logger + mainGhcThread {- +Note [Shutting down the external interpreter] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ghc monad execution (under `runGhc`) sometimes terminates abruptly: +- When the DebugAdapter exits (e.g. disconnect, terminate, error, ...), it + calls `destroyDebugSession`, which will *kill* the thread running the + debugger/Ghc session. +- When there is some exception thrown in the Ghc monad itself + +GHC wraps the `Ghc` action run with `withCleanupSession`, which is responsible +for e.g. removing temporary files and cleanly terminating the external +interpreter process, if one is being used. + +GHC first checks with `getProcessExitCode` the status of the external +interpreter, does nothing if there is some exit status, and kills the external +process otherwise. + +However, this check is incorrect(!) when the external interpreter process is +not a child of this process (which will happen in the runInTerminal external +interpreter case). `getProcessExitCode` should error with `ECHILD` in this case +(see `man 2 wait`), even if it doesn't yet (see process#359). + +Therefore, the debugger must step in and make sure the external interpreter is +exited cleanly, WITHOUT resorting to `getProcessExitCode`. To this effect, we +add our own `MC.finally cleanupInterp` call which sends the `Shutdown` message +to the external interpreter before propagating the exception further (to GHC's +`withCleanupSession`, which will now do Nothing because we set `InterpPending`, +and beyond). + +Note [Must explicitly expose module graph units] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`interactiveGhcDebugger` is our "current home unit", so its +`UnitState{moduleNameProvidersMap}` will determine which modules we can import +interactively (i.e. with GHC.setContext). + +The `moduleNameProvidersMap` has so far only been required to expose, with +`ExposePackage` flags, the other home units. However, exposing a package **does +not** imply exposing its dependencies, so `mkUnitState` was free to choose +versions/abis for us, e.g., expose haskell-debugger-view-0.2.1.0-... and hide +haskell-debugger-view-0.2.0.0-..., while the latter is the one in the graph. We +noticed with `hdv` but the above can happen with any dep of the debuggee, +causing problems at the prompt. + +Here we explicitly grab the units from the graph and make them exposed, so if we +find a unit in the graph we should be able to import exposed modules from it, +and importing modules at the prompt should use the versions the debuggee depends +on. + +An alternative, closer to what ghci does, would be to copy the `packageFlags` +from the debuggee units, however doing so doesn't take care of fixing a unitId +for dependencies of dependencies. + +Note [Do not package-qualify imports for home units] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A package-qualified module import will be looked up directly in the exposed +packages, IGNORING the home units modules. + +This can lead to two scenarios: + + 1) a package-import of a loaded unit fails, because that unit, despite being + loaded, is not installed + + 2) a package-import of a loaded unit succeeds, because a unit with the same + name (but not necessarily the same unit-id!), is installed. + +The second case can result in subtly wrong interactive sessions, where the +package-qualified imported module shadows the loaded module. Perhaps GHC could +warn about this. Cabal-repl and ghci also suffer from this subtle interaction. + +In light of this, when the debugger imports the `haskell-debugger-view` modules, +it is imperative that if the `haskell-debugger-view` unit is in the home units +(e.g. if `haskell-debugger-view` is listed in the cabal.project, like it is in +the debugger tree), we do not use a package-qualified import. + +On the other hand, if the `haskell-debugger-view` package is not in the +home-units, we *should* package-qualify it to make sure we reference the right +one. + +See also #283 +-} + +-- | See Note [Shutting down the external interpreter] +cleanupInterp :: Ghc () +cleanupInterp = do + interp <- hscInterp <$> getSession + case interpInstance interp of + InternalInterp -> pure () + ExternalInterp ext -> liftIO $ withExtInterpStatus ext $ \mstate -> do + MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do + case state of + InterpPending -> pure state -- already stopped + InterpRunning i -> do + -- Can't use `getProcessExitCode` because the interp process is + -- not necessarily a child of this process (runInTerminal case). + -- Just unconditionally try to send the message. + sendMessage i Shutdown + pure InterpPending + +-- | WARNING: callback is not to be used from other threads. +withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a +withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s) + +annotateDebuggerStackString :: String -> Debugger a -> Debugger a +annotateDebuggerStackString s (Debugger m) = Debugger $ do + r <- ReaderT $ \val -> do + withUnliftGhc $ \ unlift -> + annotateStackStringIO s (unlift $ runReaderT m val) + pure r + +-- | Variant of GHC's parseDynamicFlags which interprets paths relative to first arg. +parseDynamicFlagsWithRootDir + :: MonadIO m + => FilePath + -> Logger + -> DynFlags + -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) +parseDynamicFlagsWithRootDir rootDir logger dflags cmdline = do + (dflags1', leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline + -- flags that have just been read are used by the logger when loading package + -- env + let dflags1 = makeDynFlagsAbsoluteOverall rootDir dflags1' + let logger1 = GHC.setLogFlags logger (initLogFlags dflags1) + dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 + return (dflags2, leftovers, warns) + +-- | Make an 'ExtInterpInstance' based on an external interpreter process that +-- was launched by the DAP client via 'runInTerminal'. The process sends its +-- own PID as the first line on the socket before the GHCi wire protocol +-- begins. +extInterpFromTerminalProcess :: PortNumber -> IO Interp +extInterpFromTerminalProcess port = do + putStrLn $ "Trying to connect to " ++ show port + Control.Exception.bracketOnError + (openListener port >>= accept) + (\ (sock,_) -> close sock) + (\ (sock,_) -> do + bi_h <- socketToHandle sock ReadWriteMode + + pidLine <- annotateCallStackIO $ hGetLine bi_h + + pid <- case readMaybe pidLine :: Maybe Int of + Just pid -> pure pid + Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine + ph <- mkProcessHandle (fromIntegral pid) False + interpPipe <- mkPipeFromHandles bi_h bi_h + lock <- newMVar () + let process = InterpProcess + { interpHandle = ph + , interpPipe + , interpLock = lock + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instExtra = () + } + conf = IServConfig + { iservConfProgram = "the process is already running, we should never need to run it again" + , iservConfOpts = [] + -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger] + , iservConfDynamic = hostIsDynamic + , iservConfProfiled = hostIsProfiled + , iservConfHook = Nothing -- it's already running! + , iservConfTrace = pure () + } + + lookup_cache <- mkInterpSymbolCache + s <- newMVar $ InterpRunning inst + loader <- Loader.uninitializedLoader +#if MIN_VERSION_ghc(9,15,0) + fs_cache <- newMVar emptyFsEnv + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache) +#else + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache) +#endif + ) + +openListener :: PortNumber -> IO Socket +openListener port = do + addr <- socketAddressFromPort port + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + -- Must set before bind! + setSocketOption sock ReuseAddr 1 + + bind sock (addrAddress addr) + listen sock maxListenQueue + + return sock + +socketAddressFromPort :: PortNumber -> IO AddrInfo +socketAddressFromPort port = do + let + hints = defaultHints + { addrSocketType = Stream + , addrFlags = [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::) + , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6 + } + addrs <- getAddrInfo (Just hints) Nothing (Just (show port)) + case addrs of + addr : _ -> pure addr + [] -> fail ("Could not resolve address for external interpreter port " ++ show port) + +{- Note [Custom external interpreter] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We compile a custom external interpreter server with custom commands which make @@ -484,7 +765,28 @@ hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering +When launching the external interpreter directly attached to the user's +terminal (via runInTerminal), the handles will indeed be connected to a TTY. + [1] https://ftp.gnu.org/old-gnu/Manuals/glibc-2.2.5/html_node/Buffering-Concepts.html + +Note [Dynamic dependencies for dynamic debugger] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the external interpreter running the debuggee is a dynamically-linked +program compiled with -fPIC, it is of utmost importance that the libraries we +load (e.g. base, ghc-internal, etc) are ALSO compiled with -fPIC. Otherwise, we +end up with the same SIGILL scenario of Note [Dynamic Debuggee for dynamic debugger]. + +In #260, we battled with another SIGILL for over a week because of this. +Namely, we forgot to configure the external interpreter's +IServConfig.iservConfDynamic (and had hardcoded it to False!!). + +When loading a package to the external interpreter, GHC will consult +`iservConfDynamic` on whether to LoadDLL (dynamic lib) or LoadArchive (static +archive). This setting must definitely match the way in which the external +interpreter was compiled (checked with `hostIsDynamic`, since the external +interpreter and the debugger, while not necessarily the same process, are the +same executable). Ditto for `iservConfProfiled` (with `hostIsProfiled`). -} -------------------------------------------------------------------------------- @@ -494,11 +796,7 @@ -> m ModuleGraph -- ^ Module graph constructed from current set targets doDownsweep reuse_mg = do hsc_env <- getSession -#if MIN_VERSION_ghc(9,15,0) - let msg = batchMultiMsg hsc_env -#else let msg = batchMultiMsg -#endif (errs_base, mod_graph) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic (Just msg) (maybe [] mgModSummaries reuse_mg) [] False when (not $ null errs_base) $ do #if MIN_VERSION_ghc(9,15,0) @@ -511,11 +809,7 @@ doLoad :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> ModuleGraph -> m SuccessFlag doLoad if_cache how_much mg = do -#if MIN_VERSION_ghc(9,15,0) - msg <- batchMultiMsg <$> getSession -#else let msg = batchMultiMsg -#endif load' if_cache how_much mkUnknownDiagnostic (Just msg) mg -- | Returns @Just modName@ if the given module was successfully loaded @@ -583,14 +877,16 @@ hsc_env <- getSession let unitState = hsc_units hsc_env - -- Only looks at unit-nodes, this is not robust! - -- TODO: Better lookup of unit-id - let hskl_dbgr_vws = + -- Note: linear in the module graph but only happens once. + let potential_units = graphUnits mod_graph + -- Note: the intermediate set is expected to be small (<= 2). + let hskl_dbgr_vws = Set.toList . Set.fromList $ [ uid - | UnitNode _deps uid <- mg_mss mod_graph - , "haskell-debugger-view" `L.isPrefixOf` unitIdString uid - || "hskll-dbggr-vw" `L.isPrefixOf` unitIdString uid - || "haskell-debug_" `L.isPrefixOf` unitIdString uid + | uid <- potential_units + , let uid_s = unitIdString uid + , "haskell-debugger-view" `L.isPrefixOf` uid_s + || "hskll-dbggr-vw" `L.isPrefixOf` uid_s + || "haskell-debug_" `L.isPrefixOf` uid_s ] -- If the haskell-debugger-view is in the dependency graph, it must have @@ -601,19 +897,23 @@ case hskl_dbgr_vws of [hdv_uid] -> do -- In transitive closure, use that one. - -- Check that the version is exactly 0.2.0.0 + -- Check that the version is in supported range. case lookupUnit unitState (RealUnit (Definite hdv_uid)) of Just unitInfo -> do let version = unitPackageVersion unitInfo if any (\(l,h) -> l <= version && version < h) supported_ranges then return (Just hdv_uid) else throwM UnsupportedHsDbgViewVersion{supportedVersions=supported_ranges, actualVersion=version} + Nothing + | "inplace" `L.isSuffixOf` unitIdString hdv_uid + -- will be built as a target later + -> return (Just hdv_uid) Nothing -> error "Could not find unit info for haskell-debugger-view" [] -> do return Nothing - _ -> - error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" + _ -> do + error $ "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!" ++ showSDocUnsafe (withPprStyle (PprDump alwaysQualify) (ppr hskl_dbgr_vws)) -------------------------------------------------------------------------------- -- Utilities @@ -686,7 +986,11 @@ unit_env = hsc_unit_env hsc_env case term of Suspension{val, ty} -> do +#if MIN_VERSION_ghc(9,15,0) + r <- GHCi.seqHValue interp unit_env (hsc_logger hsc_env) val +#else r <- GHCi.seqHValue interp unit_env val +#endif () <- fromEvalResult r let forceThunks = False {- whether to force the thunk subterms -} @@ -708,6 +1012,7 @@ -> do wrapped_term' <- deepseqTerm hsc_env wrapped_term return t{wrapped_term = wrapped_term'} _ -> do seqTerm hsc_env t + -------------------------------------------------------------------------------- -- * Logging diff --git a/haskell-debugger/GHC/Debugger/Run.hs b/haskell-debugger/GHC/Debugger/Run.hs --- a/haskell-debugger/GHC/Debugger/Run.hs +++ b/haskell-debugger/GHC/Debugger/Run.hs @@ -21,13 +21,35 @@ import System.FilePath import System.Directory -import GHC +import GHC qualified +import GHC ( + ExecOptions (..), + ExecResult (..), + execStmt', + ForeignHValue, + GhciLStmt, + GhcPs, + InteractiveImport (..), + mkHsString, + ModSummary (..), + Name, + nlHsLit, + nlList, + parseImportDecl, + SingleStep (..), + SrcSpan (..), + StmtLR (..), + unLoc, + ) +import GHC.Plugins (SourceError) import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS) import GHC.Unit.Types import GHC.Data.FastString import GHC.Driver.DynFlags as GHC +import GHC.Driver.Main (hscParseStmtWithLocation) import GHC.Driver.Monad as GHC import GHC.Driver.Env as GHC +import qualified GHC.Driver.Config.Parser as GHC import GHC.Runtime.Debugger.Breakpoints as GHC import qualified GHC.Unit.Module.ModSummary as GHC import GHC.Types.Name.Occurrence (mkVarOccFS) @@ -42,6 +64,7 @@ import Colog.Core as Logger import qualified GHC.Debugger.Breakpoint.Map as BM import GHC.Debugger.Runtime.Thread +import GHC.Debugger.Session (setInteractiveDebuggerDynFlags, getInteractiveDebuggerDynFlags, resumeExec) -------------------------------------------------------------------------------- -- * Evaluation @@ -61,6 +84,7 @@ (moduleName modOfEntryFile) logSDoc Logger.Debug $ "Eval Module Context:" <+> ppr evalModule + old_context <- GHC.getContext GHC.setContext [GHC.IIModule evalModule] @@ -121,13 +145,13 @@ -- | Resume execution of the stopped debuggee program doContinue :: Debugger EvalResult doContinue = do - GHC.resumeExec RunToCompletion Nothing + resumeExec RunToCompletion Nothing >>= handleExecResult -- | Resume execution but only take a single step. doSingleStep :: Debugger EvalResult doSingleStep = do - GHC.resumeExec SingleStep Nothing + resumeExec SingleStep Nothing >>= handleExecResult doStepOut :: Debugger EvalResult @@ -135,13 +159,13 @@ mb_span <- getCurrentBreakSpan case mb_span of Nothing -> - GHC.resumeExec (GHC.StepOut Nothing) Nothing + resumeExec (GHC.StepOut Nothing) Nothing >>= handleExecResult Just loc -> do md <- fromMaybe (error "doStepOut") <$> getCurrentBreakModule ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md let current_toplevel_decl = enclosingTickSpan ticks loc - GHC.resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) Nothing + resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) Nothing >>= handleExecResult -- | Resume execution but stop at the next tick within the same function. @@ -157,43 +181,113 @@ Nothing -> error "not stopped at a breakpoint?!" Just (UnhelpfulSpan _) -> do liftIO $ putStrLn "Stopped at an exception. Forcing step into..." - GHC.resumeExec SingleStep Nothing >>= handleExecResult + resumeExec SingleStep Nothing >>= handleExecResult Just loc -> do md <- fromMaybe (error "doLocalStep") <$> getCurrentBreakModule -- TODO: Cache moduleLineMap? ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md let current_toplevel_decl = enclosingTickSpan ticks loc - GHC.resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult + resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult +-- | Generalized `doEval` that also handles `imports` +doEvalCommand :: String -> Debugger EvalResult +doEvalCommand expr = do + dflags <- getInteractiveDebuggerDynFlags + let pflags = GHC.initParserOpts dflags + if GHC.isStmt pflags expr + then doEval expr + else addImport expr + +-- | Parses input as an import declaration and applies it to the interactive context. +addImport :: String -> Debugger EvalResult +addImport s = handleError $ do + cxt <- GHC.getContext + idecl <- parseImportDecl s + GHC.setContext $ IIDecl idecl : cxt + pure $ EvalCompleted "" "" Nothing NoVariables + where + handleError m = m `catch` \ (e::SourceError) -> do + pure $ EvalAbortedWith $ displayException e + -- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context). doEval :: String -> Debugger EvalResult -doEval expr = do - excr <- (Right <$> GHC.execStmt expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e)) +doEval expr = withCurrentBreakExtensions $ do + excr <- (Right <$> exec expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e)) case excr of Left err -> pure $ EvalAbortedWith err - Right ExecBreak{} -> continueToCompletion >>= handleExecResult - Right r@ExecComplete{} -> handleExecResult r + Right (k, ExecBreak{}) -> fmap (addSourceKind k) $ continueToCompletion >>= handleExecResult + Right (k, r@ExecComplete{}) -> fmap (addSourceKind k) $ handleExecResult r + where + exec input exec_opts@ExecOptions{..} = do + hsc_env <- getSession + mb_stmt <- + liftIO $ + runInteractiveHsc hsc_env $ + hscParseStmtWithLocation execSourceFile execLineNumber input + + case mb_stmt of + -- empty statement / comment + Nothing -> return (IsStmt, ExecComplete (Right []) 0) + Just stmt -> (,) <$> stmtKind stmt <*> execStmt' stmt input exec_opts + + stmtKind (stmt :: GhciLStmt GhcPs) = do + pure $ case unLoc stmt of + BodyStmt{} -> IsExpr + _ -> IsStmt + + addSourceKind :: SourceKind -> EvalResult -> EvalResult + addSourceKind k EvalCompleted{..} = EvalCompleted{resultSourceKind = Just k, ..} + addSourceKind _ r = r + -- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'. -- -- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt. continueToCompletion :: Debugger GHC.ExecResult continueToCompletion = do - execr <- GHC.resumeExec GHC.RunToCompletion Nothing + execr <- resumeExec GHC.RunToCompletion Nothing case execr of GHC.ExecBreak{} -> continueToCompletion GHC.ExecComplete{} -> return execr +-- | @withCurrentBreakExtensions m@ executes @m@ with the language and language +-- extensions of the current breakpoint source module. +-- +-- If we are not stopped at a breakpoint @m@ is executed with no change. +withCurrentBreakExtensions :: Debugger a -> Debugger a +withCurrentBreakExtensions m = do + mmodl <- getCurrentBreakModule + case mmodl of + Nothing -> m + Just breakModule -> do + ic_dyn_flags <- getInteractiveDebuggerDynFlags + break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule + setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags + x <- m + setInteractiveDebuggerDynFlags ic_dyn_flags + return x + where + -- Possibly we might want to include more from the module's DynFlags. + -- However some are likely to mess with the REPL, e.g. Opt_WarnTypeDefaults, + -- Opt_HideAllPackages, Opt_NoIt. See discussion at + -- https://github.com/well-typed/haskell-debugger/pull/230#discussion_r2986758826 + adjustFlags :: DynFlags -> DynFlags -> DynFlags + adjustFlags ic modl = ic + { extensions = extensions modl + , extensionFlags = extensionFlags modl + , language = language modl + } + -- | Turn a GHC's 'ExecResult' into an 'EvalResult' response handleExecResult :: GHC.ExecResult -> Debugger EvalResult handleExecResult = \case ExecComplete {execResult} -> do case execResult of Left e -> return (EvalException (show e) "SomeException") - Right [] -> return (EvalCompleted "" "" NoVariables) -- Evaluation completed without binding any result. + Right [] -> return (EvalCompleted "" "" Nothing NoVariables) -- Evaluation completed without binding any result. Right (n:_ns) -> inspectName n >>= \case Just VarInfo{varValue, varType, varRef} -> do - return (EvalCompleted varValue varType varRef) + return (EvalCompleted varValue varType Nothing varRef) Nothing -> liftIO $ fail "doEval failed" ExecBreak {breakNames = _, breakPointId = Nothing} -> do -- Stopped at an exception @@ -202,37 +296,54 @@ return EvalStopped{ breakId = Nothing , breakThread = rt_id } ExecBreak {breakNames = _, breakPointId = Just bid} -> do + + let performAction BreakpointStop = do + + rt_id <- getRemoteThreadIdFromContext + return EvalStopped{ breakId = Just bid + , breakThread = rt_id } + performAction (BreakpointLogAndResume logExpr) = do + let evalFailedMsg e = text $ unlines ["Evaluation of log message expression failed with " ++ e + , "Expr: " ++ logExpr + , "Ignoring..."] + doEval' logExpr evalFailedMsg $ \ _ _ -> resume + bm <- liftIO . readIORef =<< asks activeBreakpoints case BM.lookup bid bm of - -- todo: BreakpointAfterCountCond is not handled yet. - Just (BreakpointWhenCond cond, _) -> do - let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..." - let resume = GHC.resumeExec GHC.RunToCompletion Nothing >>= handleExecResult - doEval cond >>= \case + -- When stepping (`GHC.resumeExec SingleStep` or similar), we will typically stop at locations not explicitly enabled by the user (i.e. not registered in `activeBreakpoints`). + Nothing -> performAction BreakpointStop + Just BreakpointInfo{bpInfoStatus = status, bpInfoAction = action} -> do + case status of + -- todo: BreakpointAfterCountCond is not handled yet. + BreakpointAfterCountCond{} -> performAction action + BreakpointWhenCond cond -> do + let evalFailedMsg e = text $ "Evaluation of conditional breakpoint expression failed with " ++ e ++ "\nIgnoring..." + + doEval' cond evalFailedMsg $ \ resultVal resultType -> do + if resultType == "Bool" then do + if resultVal == "True" then do + performAction action + else + resume + else do + logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"") + resume + BreakpointDisabled -> resume + -- The counting is handled by @GHC.setupBreakpoint@ + BreakpointAfterCount _ -> performAction action + BreakpointEnabled -> performAction action + where + doEval' expr evalFailedMsg k = doEval expr >>= \case EvalStopped{} -> error "impossible for doEval" EvalCompleted { resultVal, resultType } -> - if resultType == "Bool" then do - if resultVal == "True" then do - rt_id <- getRemoteThreadIdFromContext - return EvalStopped{ breakId = Just bid - , breakThread = rt_id } - else - resume - else do - logSDoc Logger.Warning (evalFailedMsg "\"expression resultType is != Bool\"") - resume + k resultVal resultType EvalException { resultVal } -> do logSDoc Logger.Warning (evalFailedMsg resultVal) resume EvalAbortedWith e -> do logSDoc Logger.Warning (evalFailedMsg e) resume - - -- Unconditionally 'EvalStopped' in all other cases - _ -> do - rt_id <- getRemoteThreadIdFromContext - return EvalStopped{ breakId = Just bid - , breakThread = rt_id } + resume = resumeExec GHC.RunToCompletion Nothing >>= handleExecResult -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'. inspectName :: Name -> Debugger (Maybe VarInfo) @@ -241,7 +352,9 @@ Nothing -> do liftIO . putStrLn =<< display (text "Failed to lookup name: " <+> ppr n) pure Nothing - Just tt -> Just <$> tyThingToVarInfo tt + Just tt -> Just <$> do + fam_envs <- getFamInstEnvs' + tyThingToVarInfo fam_envs tt getRemoteThreadIdFromContext :: Debugger RemoteThreadId getRemoteThreadIdFromContext = do diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, OrPatterns #-} -module GHC.Debugger.Runtime.Instances where +module GHC.Debugger.Runtime.Instances + ( debugValueTerm + , debugFieldsTerm + , VarValueResult(..) + ) where import GHC import GHC.Driver.Env @@ -23,16 +27,16 @@ -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugValue' method if there is one. debugValueTerm :: Term -> Debugger (Maybe VarValueResult) -debugValueTerm term@(Suspension{} ; Term{}) = do +debugValueTerm term = do hsc_env <- getSession let interp = hscInterp hsc_env let ty = termType term mbInst <- getDebugViewInstance ty - case mbInst of + case (,) <$> maybe_hval term <*> mbInst of Nothing -> return Nothing - Just DebugViewInstance - {instDebugValue, varValueIOTy} -> do - liftIO (instDebugValue (val term)) >>= \case + Just (hval, DebugViewInstance + {instDebugValue, varValueIOTy}) -> do + liftIO (instDebugValue hval) >>= \case Left _e -> -- exception! ignore. return Nothing @@ -54,12 +58,8 @@ _ -> do logSDoc Logger.Warning (text "debugValueTerm(2): Expecting" <+> ppr strTerm <+> text "to be a Term or Suspension.") return Nothing -debugValueTerm term = do - logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.") - return Nothing - -- | Get the custom representation of this 'Term' by applying a 'DebugView' -- instance 'debugFields' method if there is one. -- @@ -68,14 +68,14 @@ -- -- Returns @Nothing@ if no instance was found for the type of the given term debugFieldsTerm :: Term -> Debugger (Maybe [(String, Term)]) -debugFieldsTerm term@(Suspension{} ; Term{}) = do +debugFieldsTerm term = do let ty = termType term mbInst <- getDebugViewInstance ty - case mbInst of + case (,) <$> maybe_hval term <*> mbInst of Nothing -> return Nothing - Just DebugViewInstance - {instDebugFields, varFieldsIOTy} -> do - liftIO (instDebugFields (val term)) >>= \case + Just (hval, DebugViewInstance + {instDebugFields, varFieldsIOTy}) -> do + liftIO (instDebugFields hval) >>= \case Left _e -> -- exception! ignore. return Nothing @@ -84,6 +84,15 @@ obtainParsedTerm "VarFields" 2 True varFieldsIOTy transformed_v varFieldsParser >>= \case Left _ -> pure Nothing Right res -> pure (Just res) -debugFieldsTerm term = do - logSDoc Logger.Warning (text "debugValueTerm: Expecting" <+> ppr term <+> text "to be a Term or Suspension.") - return Nothing + +-- | The heap value of the Term the debugView instance methods are applied to +-- (looks through newtypes). For Primitive types and primitive References, +-- assume dbgInst methods can't be applied to them. +maybe_hval :: Term -> Maybe ForeignHValue +maybe_hval t = case t of + Suspension{val} -> Just val + Term{val} -> Just val + NewtypeWrap{wrapped_term} + -> maybe_hval wrapped_term + Prim{} -> Nothing + RefWrap{} -> Nothing diff --git a/haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs b/haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Interpreter.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Custom interpreter commands in addition to the existing +-- 'GHC.Runtime.Interpreter' ones. +-- +-- Similarly to 'GHC.Runtime.Interpreter', the functions in this module +-- abstract whether the external or internal interpreter is being used. +-- +-- When using the external interpreter, we leverage the "Custom external commands" +-- feature introduced in GHC 10.0's ghci API to extend the external interpreter +-- server with custom command messages and handlers. When using +-- +-- In GHC 9.14, there isn't support for extending the external interpreter server with new commands. +-- Thus, it is impossible to get the external interpreter to execute custom +-- code. When custom commands aren't available for the external interpreter we +-- fallback to an implementation which uses more primitive functions on the +-- external interpreter, decode the heap values directly into 'Term', and use +-- 'GHC.Debugger.Runtime.Term.Parser' to parse the heap 'Term's into structured +-- data. That implementation doesn't live in this module, which is meant only +-- to be the interface to the custom commands supported by GHC > 9.14. +-- +-- When using the internal interpreter, we can execute the custom command +-- handler directly in this process -- regardless of whether using GHC 9.14 or GHC 10.0. +-- In practice, for simplicity, we just use the fallback mechanism of 9.14 for both internal and external. +-- +-- The custom commands and their handlers are implemented in +-- 'GHC.Debugger.Runtime.Interpreter.Custom' +-- +-- Meant to be imported with +-- +-- @ +-- import qualified GHC.Debugger.Runtime.Interpreter as Debuggee +-- @ +-- +-- since the exported +-- functions run on the debuggee (possibly external) process. Even on GHC 9.14, +-- where we use more primitive messages and do some extra parsing on the +-- debugger/host side +module GHC.Debugger.Runtime.Interpreter + ( listThreads + , decodeThreadStack + , collectExceptionInfo + + -- * Re-exports + , ThreadInfo(..) + ) where + +import Control.Monad +import Control.Monad.IO.Class + +import GHCi.RemoteTypes +import GHC.Debugger.Monad + +import GHC.Debugger.Interface.Messages (ExceptionInfo) +import GHC.Debugger.Runtime.Interpreter.Custom + +import Data.Binary +import GHC.Driver.Env (hscInterp) +import GHC.Driver.Monad (getSession) +import GHC.Runtime.Interpreter +import Control.Concurrent +import Control.Exception + +-------------------------------------------------------------------------------- +-- * Debugger abstraction +-- +-- | The functions in this section need to be in 'Debugger' because the +-- 'TermParser' (needed to implement these top-level functions in GHC 9.14) +-- works in 'Debugger'. This also allows us to call debugger-interpreter +-- functions without 'liftIO' everywhere. +-------------------------------------------------------------------------------- + +listThreads :: Debugger [ThreadInfo ForeignRef] +listThreads = do + interp <- hscInterp <$> getSession + ts_info <- liftIO $ interpDbgCmd interp ListThreads + forM ts_info $ \ti@ThreadInfo{threadInfoRef} -> do + threadInfoForeignRef <- liftIO $ mkFinalizedHValue interp threadInfoRef + pure ti{threadInfoRef = threadInfoForeignRef} + +decodeThreadStack :: ForeignRef ThreadId -> Debugger [StackFrameInfo] +decodeThreadStack ftid = do + interp <- hscInterp <$> getSession + liftIO $ withForeignRef ftid $ + interpDbgCmd interp . DecodeThreadStack + +collectExceptionInfo :: ForeignRef SomeException -> Debugger ExceptionInfo +collectExceptionInfo excRef = do + interp <- hscInterp <$> getSession + liftIO $ withForeignRef excRef $ + interpDbgCmd interp . CollectExceptionInfo + +-------------------------------------------------------------------------------- +-- * IO+interpreter abstraction +-- +-- | Functions on IO which abstract calling the external interpreter or +-- internal interpreter using custom commands. Note that 'CustomMessage' is not +-- available in GHC 9.14 so we don't make these functions available in GHC 9.14 +-------------------------------------------------------------------------------- + +-- | Run a 'DbgInterpCmd' in the interpreter's context. By default, the command is +-- serialized and sent to an external iserv process, and the response is +-- deserialized (hence the @Binary@ constraint). With @--internal-interpreter@ +-- we execute the command directly here. +-- +-- To run a builtin 'Message' command, use 'interpCmd' instead. +interpDbgCmd :: Binary a => Interp -> DbgInterpCmd a -> IO a +interpDbgCmd interp command = case interpInstance interp of + InternalInterp -> + -- Run it directly on this process! + runDbgInterpCmd command + ExternalInterp{} + -- Use interpCmd to send the command as a custom message to external process. + -- The custom message will be processed according to the custom command + -- handlers registered with `iservWithCustom` + | let payload = encodePayload (Some @Binary command) -> do + respBytes <- interpCmd interp (CustomMessage dbgInterpCmdTag payload) + case decodePayload respBytes of + Left err -> fail err + Right r -> pure r diff --git a/haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs b/haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeAbstractions #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- necessary Binary instances +module GHC.Debugger.Runtime.Interpreter.Custom where + +import GHC.Generics (Generic) + +import GHCi.Message +import GHCi.RemoteTypes + +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Bits +import Foreign.C.String +import GHC.ByteCode.Types +import GHC.Conc.Sync +import GHC.Exts.Heap.Closures (StackFrame, GenStackFrame (..), Box (..)) +import GHC.InfoProv +import GHC.Runtime.Interpreter (evalBreakpointToId) +import GHC.Stack.Annotation.Experimental +import GHC.Utils.Encoding.UTF8 (utf8EncodeShortByteString) +import GHC.Word +import Unsafe.Coerce (unsafeCoerce, unsafeCoerce#) +import qualified GHC.Base +import qualified GHC.Exts +import qualified GHC.Exts.Heap as Heap +import qualified GHC.Stack as Stack +import GHC.Unit.Module +import Control.Exception +import GHC.Debugger.Interface.Messages (SourceSpan (..), ExceptionInfo (..)) +import Control.Exception.Context +import Data.Typeable +#if MIN_VERSION_ghc(9,15,0) +import GHC.Debugger.Interface.Messages (srcLocToSourceSpan) +import Data.Maybe +import Control.Exception.Backtrace +import GHC.Exception +import qualified GHC.Stack.CloneStack as Stack +import qualified GHC.Stack.Decode.Experimental as Stack +import qualified GHC.Exception.Backtrace.Experimental as Backtrace +#endif + +-------------------------------------------------------------------------------- +-- * Custom Commands +-------------------------------------------------------------------------------- + +data ThreadInfo ref = ThreadInfo + { threadInfoRef :: !(ref ThreadId) + , threadInfoLabel :: !(Maybe String) + , threadInfoStatus :: !ThreadStatus + } + deriving (Generic) + +-- | Information about a stack frame +data StackFrameInfo + -- | Information derived from an IPE entry + = StackFrameIPEInfo !InfoProv + -- | User-defined Stack Frame annotation + | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String + -- | Information derived from a continuation BCO breakpoint info. + | StackFrameBreakpointInfo !InternalBreakpointId + deriving (Generic) + +data DbgInterpCmd a where + ListThreads :: DbgInterpCmd [ThreadInfo RemoteRef] + DecodeThreadStack :: RemoteRef ThreadId -> DbgInterpCmd [StackFrameInfo] + CollectExceptionInfo :: RemoteRef SomeException -> DbgInterpCmd ExceptionInfo + +dbgInterpCmdTag :: Word8 +dbgInterpCmdTag = 0x25 + +-------------------------------------------------------------------------------- +-- * Running and handlers +-------------------------------------------------------------------------------- + +-- | Run a custom 'DbgInterpCmd' directly. +runDbgInterpCmd :: DbgInterpCmd a -> IO a +runDbgInterpCmd = \case + ListThreads -> mapM threadInfo =<< listThreads +#if MIN_VERSION_ghc(9,14,2) + -- decodeStackWithIpe exposed from 9.14.2 onwards (see #27065) + DecodeThreadStack threadIdRef -> do + -- We clone the stack of the thread and decode it in the external interpreter to avoid + -- any potential issues with decoding the stack in the main interpreter, which can be + -- more fragile due to optimizations and other factors. This also allows us to leverage + -- the existing machinery for decoding stacks in the external interpreter, which is more + -- robust and can handle a wider variety of cases. + threadId <- localRef threadIdRef + clonedStack <- Stack.cloneThreadStack threadId + frames <- Stack.decodeStackWithIpe clonedStack + catMaybes <$> mapM stackFrameInfo frames +#else + DecodeThreadStack _ -> fail "Decoding thread stacks is not supported on GHC versions prior to 9.14.2, which exposes the necessary decodeStackWithIpe functions. Please upgrade to GHC 9.14.2 or later to use this feature." +#endif + CollectExceptionInfo excRef -> do + exc <- localRef excRef + let info = exceptionInfo exc + return info + + +-- | Run a serialized custom 'DbgInterpCmd'. This is used in conjunction with +-- 'servWithCustom' to handle custom messages sent to the external interpreter. +dbgInterpCmdHandler :: Word8 -> BS.ByteString -> IO (Maybe BS.ByteString) +dbgInterpCmdHandler tag payload + | tag == dbgInterpCmdTag = + case decodePayload payload of + Left err -> + fail ("Failed to decode debugger thread command payload: " ++ err) + Right (Some @Bin.Binary command) -> + Just . encodePayload <$> runDbgInterpCmd command + | otherwise = + pure Nothing + +-------------------------------------------------------------------------------- +-- * Implementing each command +-------------------------------------------------------------------------------- + +-- | Read some info about a Thread from its 'ThreadId' +threadInfo :: ThreadId -> IO (ThreadInfo RemoteRef) +threadInfo threadId = do + status <- threadStatus threadId + ref <- mkRemoteRef threadId + label <- threadLabel threadId + pure ThreadInfo + { threadInfoRef = ref + , threadInfoLabel = label + , threadInfoStatus = status + } + +-- | Try to make a 'StackFrameInfo' out of the decoded stack frame information: +-- +-- 1. Try stack annotations first +-- 2. Try IPE next +-- 3. Try decoding a continuation BCO with a breakpoint next +stackFrameInfo :: (StackFrame, Maybe InfoProv) -> IO (Maybe StackFrameInfo) +stackFrameInfo (AnnFrame{annotation}, _) + | let Box annVal = annotation + , let stack_anno = displayStackAnnotation @SomeStackAnnotation (unsafeCoerce annVal) + = pure $ Just $ StackFrameAnnotation Nothing{-No source locations yet-} stack_anno +stackFrameInfo (_, Just ipe) + = pure $ Just (StackFrameIPEInfo ipe) +stackFrameInfo (RetBCO{bco}, _) + | let !(Box !bco_hval) = bco -- needs to be forced for `getClosureData` to look at the right thing. + = fmap StackFrameBreakpointInfo <$> (lookupBCOBreakpoint =<< Heap.getClosureData bco_hval) +stackFrameInfo _ + = pure Nothing + +-- | Try to find a BRK_FUN breakpoint location at the start of a BCO heap closure +lookupBCOBreakpoint :: Heap.GenClosure Box -> IO (Maybe InternalBreakpointId) +lookupBCOBreakpoint Heap.BCOClosure{..} + {- + This is highly internals dependent...: + - find the bytecode instruction (BCI) at index 0 + - BCI is Word16 (the high 8bits are for flags, low for instruction op code) + + NOTE: Assume @Opt_AddBcoName@ is not set. @Opt_AddBcoName@ moves the BRK_FUN + BCI to index 2#, but it is a debug flag used by compiler developers to debug + bytecode itself, so we shouldn't go to great lengths to support it. Other + things will be broken too. + -} + | index_at 0# .&. 0xFF == 66{-bci_BRK_FUN-} + = do + mod_name <- literalString info_mod_name_ix + mod_id <- literalString info_mod_id_ix + pure $ Just $ evalBreakpointToId EvalBreakpoint +#if MIN_VERSION_ghc(9,15,0) + { eb_info_mod = utf8EncodeShortByteString mod_name +#else + { eb_info_mod = mod_name +#endif + , eb_info_mod_unit = utf8EncodeShortByteString mod_id + , eb_info_index = fromIntegral $ brk_info_ix_hi .<<. 16 + brk_info_ix_lo + } + + | otherwise + = pure Nothing + + where + Box instrs_val = instrs + Box literals_val = literals + + index_at n = W16# (GHC.Base.indexWord16Array# (unsafeCoerce# instrs_val) n) + + -- find a string in the literals array by index + literalString :: Word16 -> IO String + literalString (fromIntegral -> GHC.Exts.I# ix) = do + peekCString $ + GHC.Exts.Ptr (GHC.Exts.indexAddrArray# (unsafeCoerce# literals_val) ix) + + _brk_arr_ix = index_at 1# + info_mod_name_ix = index_at 2# + info_mod_id_ix = index_at 3# + brk_info_ix_hi = index_at 4# + brk_info_ix_lo = index_at 5# +lookupBCOBreakpoint _ = pure Nothing + +exceptionInfo :: SomeException -> ExceptionInfo +exceptionInfo se'@(SomeException exc) = + ExceptionInfo + { exceptionInfoTypeName = simpleTypeName + , exceptionInfoFullTypeName = fullTypeName + , exceptionInfoMessage = Control.Exception.displayException se' + , exceptionInfoContext = contextText + , exceptionInfoSourceSpan = exceptionContextLocation + , exceptionInfoInner = innerNodes + } + where + ctx = someExceptionContext se' + rendered = displayExceptionContext ctx + whileHandling = getExceptionAnnotations ctx + innerNodes = map (exceptionInfo . unwrap) whileHandling + simpleTypeName = tyConName tc + modulePrefix = case tyConModule tc of + mdl | null mdl -> "" + | otherwise -> mdl ++ "." + packagePrefix = case tyConPackage tc of + pkg | null pkg -> "" + | otherwise -> pkg ++ ":" + tc = typeRepTyCon (typeOf exc) + fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName + unwrap (WhileHandling inner) = inner + contextText | null rendered = Nothing + | otherwise = Just rendered + +#if MIN_VERSION_ghc(9,15,0) + exceptionContextLocation = + let fromCallStack cs = case listToMaybe (getCallStack cs) of + Just (_, loc) -> Just (srcLocToSourceSpan loc) + Nothing -> Nothing + bts :: [Backtraces] + bts = getExceptionAnnotations ctx + in case bts of + bt : _ -> case Backtrace.btrHasCallStack bt of + Just cs -> fromCallStack cs + Nothing -> Nothing + [] -> Nothing +#else + exceptionContextLocation = Nothing {- btrHasCallstack not available -} +#endif + +-------------------------------------------------------------------------------- +-- * Binary for custom commands +-------------------------------------------------------------------------------- + +data Some c f where + Some :: c a => f a -> Some c f + +encodePayload :: Bin.Binary a => a -> BS.ByteString +encodePayload = BL.toStrict . Bin.encode + +decodePayload :: Bin.Binary a => BS.ByteString -> Either String a +decodePayload bs = + case Bin.decodeOrFail (BL.fromStrict bs) of + Left (_, _, err) -> Left err + Right (_, _, a) -> Right a + +instance Bin.Binary (Some Bin.Binary DbgInterpCmd) where + put (Some command) = case command of + ListThreads -> Bin.put (0 :: Word8) + DecodeThreadStack threadIdRef -> do + Bin.put (1 :: Word8) + Bin.put threadIdRef + CollectExceptionInfo excRef -> do + Bin.put (2 :: Word8) + Bin.put excRef + + get = do + (tag :: Word8) <- Bin.get + case tag of + 0 -> pure (Some ListThreads) + 1 -> Some . DecodeThreadStack <$> Bin.get + 2 -> Some . CollectExceptionInfo <$> Bin.get + _ -> fail ("Unknown debugger thread command tag: " ++ show tag) + +instance Bin.Binary (ThreadInfo RemoteRef) +instance Bin.Binary StackFrameInfo +instance Bin.Binary Stack.SrcLoc +instance Bin.Binary SourceSpan where + put SourceSpan{..} = do + Bin.put file + Bin.put startLine + Bin.put endLine + Bin.put startCol + Bin.put endCol + + get = do + file <- Bin.get + startLine <- Bin.get + endLine <- Bin.get + startCol <- Bin.get + endCol <- Bin.get + pure SourceSpan{..} + +instance Bin.Binary ExceptionInfo where + put ExceptionInfo{..} = do + Bin.put exceptionInfoTypeName + Bin.put exceptionInfoFullTypeName + Bin.put exceptionInfoMessage + Bin.put exceptionInfoContext + Bin.put exceptionInfoSourceSpan + Bin.put exceptionInfoInner + + get = do + exceptionInfoTypeName <- Bin.get + exceptionInfoFullTypeName <- Bin.get + exceptionInfoMessage <- Bin.get + exceptionInfoContext <- Bin.get + exceptionInfoSourceSpan <- Bin.get + exceptionInfoInner <- Bin.get + pure ExceptionInfo{..} + +instance Bin.Binary InternalBreakpointId where + put (InternalBreakpointId (Module (RealUnit (Definite unit)) name) ix) = do + Bin.put (unitString unit) + Bin.put (moduleNameString name) + Bin.put ix + put _ = error "indefinite units are not supported by haskell-debugger yet!" + get = do + unit <- stringToUnitId <$> Bin.get + name <- mkModuleName <$> Bin.get + ix <- Bin.get + pure $ InternalBreakpointId (Module (RealUnit (Definite unit)) name) ix + +instance Bin.Binary ThreadStatus where + put = \case + ThreadRunning -> Bin.put (0 :: Word8) + ThreadFinished -> Bin.put (1 :: Word8) + ThreadBlocked blockReason -> do + Bin.put (2 :: Word8) + Bin.put blockReason + ThreadDied -> Bin.put (3 :: Word8) + + get = do + (statusTag :: Word8) <- Bin.get + case statusTag of + 0 -> pure ThreadRunning + 1 -> pure ThreadFinished + 2 -> ThreadBlocked <$> Bin.get + 3 -> pure ThreadDied + _ -> fail ("Unknown thread status tag: " ++ show statusTag) + +instance Bin.Binary BlockReason where + put = \case + BlockedOnMVar -> Bin.put (0 :: Word8) + BlockedOnBlackHole -> Bin.put (1 :: Word8) + BlockedOnException -> Bin.put (2 :: Word8) + BlockedOnSTM -> Bin.put (3 :: Word8) + BlockedOnForeignCall -> Bin.put (4 :: Word8) + BlockedOnOther -> Bin.put (5 :: Word8) + + get = do + blockTag <- Bin.get + case (blockTag :: Word8) of + 0 -> pure BlockedOnMVar + 1 -> pure BlockedOnBlackHole + 2 -> pure BlockedOnException + 3 -> pure BlockedOnSTM + 4 -> pure BlockedOnForeignCall + 5 -> pure BlockedOnOther + _ -> fail ("Unknown thread block reason tag: " ++ show blockTag) + +-------------------------------------------------------------------------------- diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Thread.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OrPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} @@ -9,13 +10,13 @@ module GHC.Debugger.Runtime.Thread ( getRemoteThreadIdFromRemoteContext , getRemoteThreadId - , getRemoteThreadsLabels , listAllLiveRemoteThreads + + -- * Re-exports + , ThreadInfo(..) ) where import Data.Maybe -import Data.Functor -import Control.Applicative import Control.Concurrent import Control.Monad import Control.Monad.IO.Class @@ -36,9 +37,17 @@ import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Thread.Map +import GHC.Debugger.Runtime.Interpreter.Custom import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote +#if MIN_VERSION_ghc(9,15,0) +import qualified GHC.Debugger.Runtime.Interpreter as Debuggee +#else +import Data.Functor +import Control.Applicative +#endif + -- | Get a 'RemoteThreadId' from a remote 'ResumeContext' gotten from an 'ExecBreak' getRemoteThreadIdFromRemoteContext :: ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId getRemoteThreadIdFromRemoteContext fctxt = do @@ -53,6 +62,23 @@ getRemoteThreadId (castForeignRef threadIdVal) _ -> liftIO $ fail "Expected threadIdTerm to be a Term!" +-- | Call 'listThreads' on the (possibly) remote debuggee process to get the +-- list of threads running on the debuggee. Filter by running threads +-- This may include the debugger threads if using the internal interpreter. +listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ThreadInfo ForeignRef)] +listAllLiveRemoteThreads = do +#if MIN_VERSION_ghc(9,15,0) + threadInfos <- Debuggee.listThreads +#else + threadInfos <- GHC.Debugger.Runtime.Thread.listThreads +#endif + fmap catMaybes $ + forM threadInfos $ \ti -> do + rti <- getRemoteThreadId ti.threadInfoRef + pure $ case ti.threadInfoStatus of + (ThreadRunning ; ThreadBlocked{}) -> Just (rti, ti) + (ThreadDied ; ThreadFinished) -> Nothing + getRemoteThreadId :: ForeignRef ThreadId -> Debugger RemoteThreadId getRemoteThreadId threadIdRef = do thread_id_fv <- expectRight =<< Remote.eval @@ -75,6 +101,26 @@ return (RemoteThreadId tid_int) +#if MIN_VERSION_ghc(9,15,0) +-- The needed functions are imported from GHC.Debugger.Runtime.Interpreter, +-- which abstracts over the custom interpreter commands. +#else +-------------------------------------------------------------------------------- +-- ** GHC 9.14: use @evalX@ and @TermParser@ to do it without custom commands +-------------------------------------------------------------------------------- + +listThreads :: Debugger [ThreadInfo ForeignRef] +listThreads = do + threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads + labels <- getRemoteThreadsLabels threads_fvs + forM (zip threads_fvs labels) $ \(castForeignRef -> thread_fv, label) -> do + status <- getRemoteThreadStatus thread_fv + pure ThreadInfo + { threadInfoStatus = status + , threadInfoLabel = label + , threadInfoRef = thread_fv + } + -- | Is the remote thread running or blocked (NOT finished NOR dead)? getRemoteThreadStatus :: ForeignRef ThreadId -> Debugger ThreadStatus getRemoteThreadStatus threadIdRef = do @@ -90,33 +136,11 @@ Right thrdStatus -> return thrdStatus -isRemoteThreadLive :: ForeignRef ThreadId -> Debugger Bool -isRemoteThreadLive r = getRemoteThreadStatus r <&> \case - (ThreadRunning ; ThreadBlocked{}) -> True - (ThreadDied ; ThreadFinished) -> False - --- | Call 'listThreads' on the (possibly) remote debuggee process to get the --- list of threads running on the debuggee. Filter by running threads --- This may include the debugger threads if using the internal interpreter. -listAllLiveRemoteThreads :: Debugger [(RemoteThreadId, ForeignRef ThreadId)] -listAllLiveRemoteThreads = do - threads_fvs <- expectRight =<< Remote.evalIOList Remote.listThreads - catMaybes <$> do - forM threads_fvs $ \(castForeignRef -> thread_fv) -> do - isLive <- isRemoteThreadLive thread_fv - if isLive then do - tid <- getRemoteThreadId thread_fv - pure $ Just (tid, thread_fv) - else do - pure Nothing - --- | Get the label of a Thread in a remote process. Returns one element per --- given Thread with @Just string@ if a label was found. getRemoteThreadsLabels :: [ForeignRef ThreadId] -> Debugger [Maybe String] getRemoteThreadsLabels threadIdRefs = do forM threadIdRefs $ \threadIdRef -> do - + r <- Remote.evalIOList $ Remote.do mb_str <- Remote.threadLabel (Remote.ref threadIdRef) Remote.return (Remote.maybeToList mb_str) @@ -127,11 +151,9 @@ _ -> liftIO $ fail "Unexpected result from evaluating \"threadLabel\"" -------------------------------------------------------------------------------- --- * TermParsers +-- *** TermParsers -------------------------------------------------------------------------------- --- ** Threads ------------------------------------------------------------------ - threadStatusParser :: TermParser ThreadStatus threadStatusParser = do (matchConstructorTerm "ThreadRunning" $> ThreadRunning) @@ -148,3 +170,4 @@ <|> (matchConstructorTerm "BlockedOnForeignCall" $> BlockedOnForeignCall) <|> (matchConstructorTerm "BlockedOnOther" $> BlockedOnOther) +#endif diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs @@ -12,9 +12,16 @@ , getRemoteThreadStackCopy ) where +import Control.Concurrent +import GHCi.RemoteTypes +import GHC.Debugger.Monad +import GHC.Debugger.Runtime.Interpreter.Custom + +#if MIN_VERSION_ghc(9,15,0) +import qualified GHC.Debugger.Runtime.Interpreter as Debuggee +#else import Data.Bits import Data.Maybe -import Control.Concurrent import Control.Applicative import Control.Monad import Control.Monad.IO.Class @@ -32,32 +39,24 @@ import GHC.Utils.Outputable import GHCi.Message -import GHCi.RemoteTypes import Colog.Core as Logger -import GHC.Debugger.Monad import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Eval import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote +#endif -------------------------------------------------------------------------------- -- * Thread stack frames -------------------------------------------------------------------------------- --- | Information about a stack frame -data StackFrameInfo - -- | Information derived from an IPE entry - = StackFrameIPEInfo !InfoProv - -- | User-defined Stack Frame annotation - | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String - -- | Information derived from a continuation BCO breakpoint info. - | StackFrameBreakpointInfo !InternalBreakpointId - -- | Clone the stack of the given remote thread and get the breakpoint ids of available frames getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo] getRemoteThreadStackCopy threadIdRef = do - +#if MIN_VERSION_ghc(9,15,0) + Debuggee.decodeThreadStack threadIdRef +#else l <- Remote.evalIOList $ Remote.do clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef) frames <- Remote.decodeStackWithIpe clonedStack @@ -79,7 +78,11 @@ return Nothing Right tm -> return tm +#endif +#if MIN_VERSION_ghc(9,15,0) +-- Nothing needed in this case :) +#else -------------------------------------------------------------------------------- -- ** Decoding Stack Frames ---------------------------------------------------- -------------------------------------------------------------------------------- @@ -225,3 +228,4 @@ logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs)) liftIO $ fail "Failed to parse BCOClosure's BRK_FUN" Right r -> return r +#endif diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} -- | Initialise the GHC session for one or more home units. -- @@ -25,10 +26,17 @@ enableExternalInterpreter, enableDynamicDebuggee, setPgmI, addOptI, - setDynFlagWays + setDynFlagWays, + makeDynFlagsAbsoluteOverall, + resumeExec, + setExposedInUnit, + graphUnits, ) where +#if MIN_VERSION_ghc(9,14,2) +import Data.Function ((&)) +#endif import Control.Monad import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H @@ -65,6 +73,10 @@ import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer) +import GHC (SingleStep, ExecResult) +import Data.Set (Set) +import qualified GHC.Unit as GHC +import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -117,6 +129,7 @@ let targets = HIE.makeTargetsAbsolute root_canon targets' cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts let dflags'' = + makeDynFlagsDirsAbsolute compRoot $ setWorkingDirectory root $ setCacheDirs cacheDirs $ enableByteCodeGeneration $ @@ -134,31 +147,21 @@ -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's. -- The first 'DynFlags' are the 'DynFlags' for the interactive session. -createUnitEnvFromFlags :: DynFlags -> [DynFlags] -> IO HomeUnitGraph -createUnitEnvFromFlags initialDynFlags unitDflags = do - let - newInternalUnitEnv dflags hpt = mkHomeUnitEnv State.emptyUnitState Nothing dflags hpt Nothing - - unitEnvList <- traverse (\dflags -> do - emptyHpt <- emptyHomePackageTable - pure (homeUnitId_ dflags, newInternalUnitEnv dflags emptyHpt)) unitDflags +createHomeUnitGraph :: GHC.Logger -> [DynFlags] -> IO HomeUnitGraph +createHomeUnitGraph logger unitDflags = do + let home_units = Set.fromList $ map homeUnitId_ unitDflags + unitEnvList <- flip traverse unitDflags $ \ dflags -> do + hue <- setupNewHomeUnitEnv logger dflags Nothing home_units + pure (homeUnitId_ dflags, hue) - interactiveHomeUnit <- do - let interactiveDynFlags = initialDynFlags - { homeUnitId_ = interactiveGhcDebuggerUnitId - , importPaths = [] - , packageFlags = - [ ExposePackage - ("-package-id " ++ unitIdString unitId) - (UnitIdArg $ RealUnit (Definite unitId)) - (ModRenaming True []) - | (unitId, _) <- unitEnvList - ] - } - emptyHpt <- emptyHomePackageTable - pure (homeUnitId_ interactiveDynFlags, newInternalUnitEnv interactiveDynFlags emptyHpt) + pure $ unitEnv_new (Map.fromList unitEnvList) - pure $ unitEnv_new (Map.fromList (interactiveHomeUnit : unitEnvList)) +setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv +setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do + emptyHpt <- emptyHomePackageTable + (dbs,unit_state,home_unit,mconstants) <- State.initUnits logger dflags cached_dbs other_home_units + updated_dflags <- GHC.updatePlatformConstants dflags mconstants + pure $ mkHomeUnitEnv unit_state (Just dbs) updated_dflags emptyHpt (Just home_unit) -- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this -- 'HscEnv'. @@ -167,51 +170,94 @@ initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv initHomeUnitEnv unitDflags env = do let dflags0 = hsc_dflags env - -- additionally, set checked dflags so we don't lose fixes - initial_home_graph <- createUnitEnvFromFlags dflags0 unitDflags - let home_units = unitEnv_keys initial_home_graph - init_home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let dflags = homeUnitEnv_dflags homeUnitEnv - old_hpt = homeUnitEnv_hpt homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags Nothing home_units - updated_dflags <- GHC.updatePlatformConstants dflags mconstants - pure HomeUnitEnv - { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs - , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit - } - let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList init_home_unit_graph + initial_home_graph <- createHomeUnitGraph (hsc_logger env) unitDflags - let homeUnitEnv = fromJust $ HUG.unitEnv_lookup_maybe interactiveGhcDebuggerUnitId init_home_unit_graph - dflags = homeUnitEnv_dflags homeUnitEnv - old_hpt = homeUnitEnv_hpt homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags (Just cached_unit_dbs) home_units + -- We set up the interactive debugger home unit after the other home units + -- have been initialised. + -- This allows us to reuse the package databases and their respective visibilities. + interactiveHomeUnit <- do + let + home_units = unitEnv_keys initial_home_graph - updated_dflags <- GHC.updatePlatformConstants dflags mconstants - let ie = HomeUnitEnv + interactiveDynFlags = dflags0 + { homeUnitId_ = interactiveGhcDebuggerUnitId + , importPaths = [] + , packageFlags = + [ ExposePackage + (unitIdString home_unit_id) + (UnitIdArg $ RealUnit (Definite home_unit_id)) + (ModRenaming True []) + | home_unit_id <- Set.toList home_units + ] + } + + let cached_unit_dbs = concat . catMaybes . fmap homeUnitEnv_unit_dbs $ Foldable.toList initial_home_graph + setupNewHomeUnitEnv (hsc_logger env) interactiveDynFlags (Just cached_unit_dbs) home_units + + let home_unit_graph = + HUG.unitEnv_insert interactiveGhcDebuggerUnitId interactiveHomeUnit initial_home_graph + + let interactiveDFlags = homeUnitEnv_dflags interactiveHomeUnit + unit_env <- + initUnitEnv interactiveGhcDebuggerUnitId home_unit_graph (GHC.ghcNameVersion interactiveDFlags) (targetPlatform interactiveDFlags) + pure $ hscSetFlags interactiveDFlags $ hscSetUnitEnv unit_env env + +-- | Extracts @UnitId@s from the graph. +graphUnits :: GHC.ModuleGraph -> [UnitId] +graphUnits mod_graph = L.nubOrd . + (`mapMaybe` mg_mss mod_graph) $ \case + UnitNode _deps uid -> Just uid + ModuleNode _ modl -> Just $ mnkUnitId $ mnKey modl + InstantiationNode uid _ -> Just uid + LinkNode _ _ -> Nothing + +-- | Rebuilds the UnitState of the unit, exposing the given packages. +-- +-- Takes care of updating hsc_dflags, ue_platform, and ue_namever if this is the ue_currentUnit. +setExposedInUnit :: UnitId -> [UnitId] -> Ghc () +setExposedInUnit unitId exposed = do + env <- GHC.getSession + let old_ie = case lookupHugUnitId unitId (hsc_HUG env) of + Just hue -> hue + Nothing -> error $ "setExposedInUnit: unit not found " ++ unitIdString unitId + + let dflags = (homeUnitEnv_dflags old_ie) { packageFlags = [ExposePackage + (unitIdString uid) + (UnitIdArg $ RealUnit (Definite uid)) + (ModRenaming True []) + | uid <- exposed + , uid /= rtsUnitId + , uid /= ghcInternalUnitId + , unitIdString uid /= "haskell-debugger-view-in-memory" + -- FIXME: any other to filter out? + ]} + let cached_dbs = homeUnitEnv_unit_dbs old_ie + let home_units = Set.fromList $ State.homeUnitDepends $ homeUnitEnv_units old_ie + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger env) dflags cached_dbs home_units + + updated_dflags <- liftIO $ GHC.updatePlatformConstants dflags mconstants + let ie = old_ie { homeUnitEnv_units = unit_state , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = old_hpt , homeUnitEnv_home_unit = Just home_unit } - let home_unit_graph = HUG.unitEnv_insert interactiveGhcDebuggerUnitId ie init_home_unit_graph - - let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup interactiveGhcDebuggerUnitId home_unit_graph - let unit_env = UnitEnv - { ue_platform = targetPlatform dflags1 - , ue_namever = GHC.ghcNameVersion dflags1 - , ue_home_unit_graph = home_unit_graph - , ue_current_unit = interactiveGhcDebuggerUnitId - , ue_module_graph = ue_module_graph (hsc_unit_env env) - , ue_eps = ue_eps (hsc_unit_env env) - } - pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env - + let home_unit_graph = HUG.unitEnv_insert unitId ie (hsc_HUG env) + let ue0 = hsc_unit_env env + let ue1 = ue0 {ue_home_unit_graph = home_unit_graph} + let + new_env + | ue_currentUnit ue1 /= unitId = hscSetUnitEnv ue1 env + | otherwise = hscSetFlags dflags1 $ hscSetUnitEnv ue2 env + where + dflags1 = homeUnitEnv_dflags $ unitEnv_lookup unitId (ue_home_unit_graph ue1) + ue2 = ue1 + { ue_platform = targetPlatform dflags1 + , ue_namever = GHC.ghcNameVersion dflags1 + } + GHC.setSession new_env -- | Setup the given 'HscEnv' to hold a 'UnitEnv' -- with all the given components. @@ -400,6 +446,18 @@ #endif } +-- | Prefixes output directories (i.e. @hiDir@, @hieDir@, @stubDir@, @dumpDir@) with @rootDir@ argument. +makeDynFlagsDirsAbsolute :: FilePath -> DynFlags -> DynFlags +makeDynFlagsDirsAbsolute rootDir df0 = + foldl' (\ df f -> f (fmap $ normalise . (rootDir )) df) df0 + [(\ f df -> df {hiDir = f (hiDir df)}) + ,(\ f df -> df {hieDir = f (hieDir df)}) + ,(\ f df -> df {stubDir = f (stubDir df)}) + ,(\ f df -> df {dumpDir = f (dumpDir df)})] + +makeDynFlagsAbsoluteOverall :: FilePath -> DynFlags -> DynFlags +makeDynFlagsAbsoluteOverall rootDir df0 = makeDynFlagsDirsAbsolute rootDir $ makeDynFlagsAbsolute rootDir df0 + -- | If the compiler supports `.gbc` files (>= 9.14.2), then persist these -- artefacts to disk. enableByteCodeGeneration :: DynFlags -> DynFlags @@ -464,6 +522,41 @@ dflags3 = foldr GHC.unSetGeneralFlag' dflags2 (wayUnsetGeneralFlags platform w) in dflags3 + +-- ---------------------------------------------------------------------------- +-- Wrappers around GHC's odd behavior +-- ---------------------------------------------------------------------------- + +resumeExec :: GhcMonad m => SingleStep -> Maybe Int -> m ExecResult +resumeExec a b = do + -- IC's ic_imports field is not kept in sync with ic_gre_cache, so we could do + -- this call later, but why rely on that. + imports <- GHC.getContext + + v <- GHC.resumeExec a b + + -- To have interactive imports persist after a `continue` command we have to + -- work around how GHC.resumeExec handles the InteractiveContext (IC). + -- + -- GHC.resumeExec resets the scope of the IC (i.e. ic_gre_cache) to what it + -- was before the last ExecBreak. + -- + -- It makes sense for GHC.resumeExec to remove from the IC scope the + -- breakpoint locals and anything that could have been defined with them, in + -- fact they are also unloaded. + -- + -- The way it's done though also rollbacks any import statements that were + -- executed since the last ExecBreak. The only fix is to reimport everything + -- again. + -- + -- Note: GHC.setContext recomputes the scope of the interactive imports from + -- scratch everytime. Considering `runDebugger` adds the whole home unit to + -- the interactive imports this might become a bottleneck. GHC does not keep + -- any reference to the scope containing just the imports, so we would have to + -- cache it ourselves (and then extend it with the cached scope of + -- ic_tythings, i.e. igre_prompt_env (c.f. replaceImportEnv)). + GHC.setContext imports + pure v -- ---------------------------------------------------------------------------- -- Utils that we need, but don't want to incur an additional dependency for. diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -100,7 +100,7 @@ , importPaths = [] , packageFlags = [ ExposePackage - ("-package-id " ++ unitIdString unitId) + (unitIdString unitId) (UnitIdArg $ RealUnit (Definite unitId)) (ModRenaming True []) | unitId <- base_uids diff --git a/haskell-debugger/GHC/Debugger/Session/Interactive.hs b/haskell-debugger/GHC/Debugger/Session/Interactive.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Session/Interactive.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module GHC.Debugger.Session.Interactive where + +import Control.Monad.IO.Class +import Data.Maybe + +#if MIN_VERSION_ghc(9,15,0) +import GHC.Linker.Types (modifyHomePackageBytecodeState) +#endif +import GHC +import GHC.Driver.Config +import GHC.Driver.DynFlags as GHC +import GHC.Driver.Env +import GHC.Driver.Main +import qualified GHC.Linker.Loader as Loader +import GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Context as GHCi +import GHCi.RemoteTypes (HValueRef) + +-- | Defines a strict @noPrintConstant :: a -> IO ()@ while taking care not to introduce its OccName into scope. +defineNoPrint :: Ghc Name +defineNoPrint = do + let ExecOptions{execSourceFile,execLineNumber} = GHC.execOptions + hsc_env <- getSession + let input = "let noPrintConstant x = x `Prelude.seq` Prelude.return () :: Prelude.IO ()" + stmt <- + liftIO $ fmap (fromMaybe $ error "impossible: parsing noPrintConstant") $ + runInteractiveHsc hsc_env $ + hscParseStmtWithLocation execSourceFile execLineNumber input + + mr <- execStmtNoOccEnv stmt + case mr of + Just ExecComplete{execResult = Right [n]} -> return n + _ -> error "impossible: defining noPrintConstant" + +-- | Executes a statement to completion without bringing any OccName in scope. +execStmtNoOccEnv :: GhcMonad m => GhciLStmt GhcPs -> m (Maybe ExecResult) +execStmtNoOccEnv stmt = do + hsc_env <- getSession + let interp = hscInterp hsc_env + + -- Turn off -fwarn-unused-local-binds when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds + hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }}) + + r <- liftIO $ hscParsedStmt hsc_env' stmt + + case r of + Nothing -> + -- empty statement / comment + return (Just $ ExecComplete (Right []) 0) + Just (ids, hval, _fix_env) -> do + -- updateFixityEnv fix_env + + status <- + liftIO $ do + let eval_opts = initEvalOpts idflags' EvalStepNone + evalStmt interp eval_opts (EvalThis hval) + + handleCompleted extendInteractiveContextWithIdsNoOccEnv ids status + +handleCompleted :: GhcMonad m + => (InteractiveContext -> [Id] -> InteractiveContext) + -> [Id] + -> EvalStatus_ [ForeignHValue] [HValueRef] + -> m (Maybe ExecResult) +handleCompleted extendIC final_ids status = do + hsc_env <- getSession + let + interp = hscInterp hsc_env + case status of + + -- Completed successfully + EvalComplete allocs (EvalSuccess hvals) -> do + let + final_ic = extendIC (hsc_IC hsc_env) final_ids + final_names = map getName final_ids +#if MIN_VERSION_ghc(9,15,0) + liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) +#else + liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) +#endif + -- hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + setSession $ hsc_env{hsc_IC=final_ic} + return (Just $ ExecComplete (Right final_names) allocs) + _ -> return Nothing + +-- | Extend the @InteractiveContext@ with the @Id@s without bringing their @OccName@s in scope. +extendInteractiveContextWithIdsNoOccEnv :: InteractiveContext -> [Id] -> InteractiveContext +extendInteractiveContextWithIdsNoOccEnv ictxt new_ids + | null new_ids = ictxt + | otherwise + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ ic_tythings ictxt + } + -- no change to ic_gre_cache as that deals with OccNames + where + new_tythings = map AnId new_ids diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase, DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns, - TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf #-} + TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf, OverloadedRecordDot #-} module GHC.Debugger.Stopped where import Control.Monad @@ -35,7 +35,6 @@ import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils import qualified Colog.Core as Logger -import qualified GHC.Stack.Types as Stack {- Note [Don't crash if not stopped] @@ -78,16 +77,15 @@ -- let (t_ids, remote_refs) = unzip (threadMapToList tmap) -- -- Oh, try the listThreads just for fun. - (t_ids, remote_refs) <- unzip <$> listAllLiveRemoteThreads - t_labels <- getRemoteThreadsLabels remote_refs + (t_ids, t_infos) <- unzip <$> listAllLiveRemoteThreads let - _mkDebuggeeThread tid tlbl + _mkDebuggeeThread tid tinfo = DebuggeeThread { tId = tid - , tName = tlbl + , tName = tinfo.threadInfoLabel } _all_threads - = zipWith _mkDebuggeeThread t_ids t_labels + = zipWith _mkDebuggeeThread t_ids t_infos -- TODO: We ignore _all_threads and report only the main execution thread for now. -- See #138 for progress on Multi-threaded debugging. @@ -184,7 +182,7 @@ , breakId = Just ibi } _ -> do - mExcSpan <- exceptionSourceSpanFromContext + mExcSpan <- exceptionInfoSourceSpan <$> getExceptionInfo req_tid case mExcSpan of Just sourceSpan -> return $ Just DbgStackFrame { name = GHC.resumeDecl r @@ -194,16 +192,6 @@ Nothing -> return Nothing return (maybe id (:) head_frame $ decoded_frames) -srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan -srcLocToSourceSpan srcLoc = - SourceSpan - { file = Stack.srcLocFile srcLoc - , startLine = Stack.srcLocStartLine srcLoc - , endLine = Stack.srcLocEndLine srcLoc - , startCol = Stack.srcLocStartCol srcLoc - , endCol = Stack.srcLocEndCol srcLoc - } - -------------------------------------------------------------------------------- -- * Scopes -------------------------------------------------------------------------------- @@ -277,6 +265,7 @@ frames <- getStacktrace threadId let frame = frames !! frameIx hsc_env <- getSession + fam_envs <- getFamInstEnvs' case vk of -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`) -- (VARR)(b,c) @@ -294,7 +283,7 @@ term' <- forceTerm term - vi <- termToVarInfo key term' + vi <- termToVarInfo fam_envs key term' return (ForcedVariable vi) @@ -305,14 +294,14 @@ -- Meaning the @SpecificVariable@ request means to inspect the structure. -- Return ONLY the fields - termVarFields key term >>= \case + termVarFields fam_envs key term >>= \case VarFields vfs -> pure (VariableFields vfs) -- (VARR)(a) from here onwards LocalVariables -> fmap VariableFields $ do -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r) - mapM tyThingToVarInfo =<< GHC.getBindings + mapM (tyThingToVarInfo fam_envs) =<< GHC.getBindings ModuleVariables | frameIx < length frames @@ -323,7 +312,7 @@ things <- typeEnvElts <$> getTopEnv curr_modl mapM (\tt -> do nameStr <- display (getName tt) - vi <- tyThingToVarInfo tt + vi <- tyThingToVarInfo fam_envs tt return vi{varName = nameStr}) things GlobalVariables @@ -345,7 +334,7 @@ , varRef = NoVariables } Just tt -> do - vi <- tyThingToVarInfo tt + vi <- tyThingToVarInfo fam_envs tt return vi{varName = nameStr} ) names diff --git a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs @@ -5,95 +5,32 @@ -- These helpers execute code on the remote process which teach us information -- about the exception we are stopped at. module GHC.Debugger.Stopped.Exception - ( exceptionSourceSpanFromContext - , getExceptionInfo - , fallbackExceptionSourceSpan + ( getExceptionInfo , defaultExceptionInfo - , currentlyStoppedOnException ) where -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe import GHC -import GHC.Types.SrcLoc -import GHC.Data.FastString (unpackFS) -import GHC.Utils.Outputable as Ppr import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages - ( SourceSpan(..) - , ExceptionInfo(..) + ( ExceptionInfo(..) , RemoteThreadId(..) ) -import qualified Colog.Core as Logger import GHC.Debugger.Runtime.Thread +import GHCi.RemoteTypes +#if MIN_VERSION_ghc(9,15,0) +import qualified GHC.Debugger.Runtime.Interpreter as Debuggee +#else +import GHC.Builtin.Types (anyTy) import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import GHC.Debugger.Runtime.Term.Parser -import GHCi.RemoteTypes (castForeignRef) -import GHC.Builtin.Types (anyTy) - --- | Attempt to obtain a more precise 'SourceSpan' for the exception we stopped --- on by consulting its context, if available. -exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan) -exceptionSourceSpanFromContext = do - GHC.getResumeContext >>= \case - r:_ | Nothing <- GHC.resumeBreakpointId r -> do - let excRef = resumeApStack r - evalRes <- Remote.eval - (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef) - case evalRes of - Left err -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err) - return Nothing - Right fhv -> do - parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv) - (maybeParser exceptionLocationTupleParser) - case parsed of - Left errs -> do - logSDoc Logger.Debug $ - Ppr.text "Failed to parse exception context location:" - Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs) - return Nothing - Right Nothing -> return Nothing - Right (Just (file, srcLine, col)) -> - return $ Just SourceSpan - { file = file - , startLine = srcLine - , startCol = col - , endLine = srcLine - , endCol = col - } - _ -> return Nothing - -exceptionLocationTupleParser :: TermParser (String, Int, Int) -exceptionLocationTupleParser = - (,,) <$> subtermWith 0 stringParser - <*> subtermWith 1 intParser - <*> subtermWith 2 intParser - --- | This helper looks at the exception context for an exception, and retrieves --- the last entry of the HasCallStack backtrace. -exceptionLocationExpr :: String -exceptionLocationExpr = """ - let - fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of - Data.Maybe.Just (_, loc) - -> Data.Maybe.Just - ( GHC.Exception.srcLocFile loc - , GHC.Exception.srcLocStartLine loc - , GHC.Exception.srcLocStartCol loc) - go exc = - let ctx = Control.Exception.someExceptionContext exc - bts :: [Control.Exception.Backtrace.Backtraces] - bts = Control.Exception.Context.getExceptionAnnotations ctx - in case bts of - bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of - Data.Maybe.Just cs -> fromCallStack cs - Data.Maybe.Nothing -> Data.Maybe.Nothing - [] -> Data.Maybe.Nothing - in go -""" +import GHC.Debugger.Interface.Messages (SourceSpan(..)) +import GHC.Utils.Outputable as Ppr +import qualified Colog.Core as Logger +#endif +import Control.Exception (SomeException) -- | Retrieve structured exception information for the requested thread when -- the debugger is currently stopped on an exception. @@ -105,18 +42,21 @@ case (r_tid == req_tid, GHC.resumeBreakpointId r) of (True, Nothing) -> do let excRef = resumeApStack r - fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef + fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext (castForeignRef excRef) _ -> return defaultExceptionInfo -- | Evaluate helper code inside the debuggee that turns the exception context -- into our 'ExceptionInfo' structure. -exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo) +exceptionInfoFromContext :: ForeignRef SomeException -> Debugger (Maybe ExceptionInfo) exceptionInfoFromContext excRef = do +#if MIN_VERSION_ghc(9,15,0) + Just <$> Debuggee.collectExceptionInfo excRef +#else -- 1. Add a "data" declaration for the datatype the expression will return _ <- runDecls exceptionInfoData -- 2. Gather information about the exception. evalRes <- Remote.eval - (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef) + (Remote.raw exceptionInfoExpr `Remote.app` Remote.ref excRef) case evalRes of Left err -> do logSDoc Logger.Debug $ @@ -142,14 +82,37 @@ <*> subtermWith 1 stringParser <*> subtermWith 2 stringParser <*> subtermWith 3 (maybeParser stringParser) - <*> subtermWith 4 (parseList exceptionInfoParser) + <*> subtermWith 4 (maybeParser exceptionLocationTupleParser) + <*> subtermWith 5 (parseList exceptionInfoParser) + where + -- Parsed from @(String, Int, Int)@. + exceptionLocationTupleParser :: TermParser SourceSpan + exceptionLocationTupleParser = do + locFile <- subtermWith 0 stringParser + srcLine <- subtermWith 1 intParser + srcCol <- subtermWith 2 intParser + pure SourceSpan + { file = locFile + , startLine = srcLine + , startCol = srcCol + , endLine = srcLine + , endCol = srcCol + } -- | Definition for the helper 'ExceptionInfoNode' data type compiled into the -- debuggee to aid in transporting nested exception information. -- We need a specific datatype because ExceptionInfoNode is recursive. exceptionInfoData :: String -exceptionInfoData = - "data ExceptionInfoNode = ExceptionInfoNode String String String (Data.Maybe.Maybe String) [ExceptionInfoNode]" +exceptionInfoData = """ + data ExceptionInfoNode = ExceptionInfoNode + { exceptionNodeTypeName :: String + , exceptionNodeFullTypeName :: String + , exceptionNodeMessage :: String + , exceptionNodeContext :: Data.Maybe.Maybe String + , exceptionNodeSourceSpan :: Data.Maybe.Maybe (String, Int, Int) + , exceptionNodeInner :: [ExceptionInfoNode] + } + """ -- | Helper expression run in the debuggee that walks the exception context and -- populates the 'ExceptionInfoNode' structure. @@ -163,6 +126,7 @@ rendered = Control.Exception.Context.displayExceptionContext ctx whileHandling = Control.Exception.Context.getExceptionAnnotations ctx innerNodes = Prelude.map (collectExceptionInfo Prelude.. unwrap) whileHandling + sourceSpan = exceptionContextLocation ctx simpleTypeName = Data.Typeable.tyConName tc modulePrefix = case Data.Typeable.tyConModule tc of mdl | Prelude.null mdl -> \"\" @@ -175,30 +139,32 @@ unwrap (Control.Exception.WhileHandling inner) = inner contextText = if Prelude.null rendered then Data.Maybe.Nothing else Data.Maybe.Just rendered in ExceptionInfoNode - simpleTypeName - fullTypeName - (Control.Exception.displayException se') - contextText - innerNodes + { exceptionNodeTypeName = simpleTypeName + , exceptionNodeFullTypeName = fullTypeName + , exceptionNodeMessage = Control.Exception.displayException se' + , exceptionNodeContext = contextText + , exceptionNodeSourceSpan = sourceSpan + , exceptionNodeInner = innerNodes + } + exceptionContextLocation ctx = + let fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of + Data.Maybe.Just (_, loc) -> + Data.Maybe.Just + ( GHC.Exception.srcLocFile loc + , GHC.Exception.srcLocStartLine loc + , GHC.Exception.srcLocStartCol loc + ) + Data.Maybe.Nothing -> Data.Maybe.Nothing + bts :: [Control.Exception.Backtrace.Backtraces] + bts = Control.Exception.Context.getExceptionAnnotations ctx + in case bts of + bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of + Data.Maybe.Just cs -> fromCallStack cs + Data.Maybe.Nothing -> Data.Maybe.Nothing + [] -> Data.Maybe.Nothing in collectExceptionInfo """ - - --- | When no precise exception location is available, fall back to displaying a --- label derived from the provided 'SrcSpan'. -fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan -fallbackExceptionSourceSpan mspan = - let fileLabel = maybe "" spanLabel mspan - in SourceSpan - { file = fileLabel - , startLine = 0 - , startCol = 0 - , endLine = 0 - , endCol = 0 - } - where - spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss) - spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason) +#endif -- | Placeholder exception info returned when the context could not be -- inspected. @@ -208,14 +174,6 @@ , exceptionInfoFullTypeName = "Exception" , exceptionInfoMessage = "Exception information not available" , exceptionInfoContext = Nothing + , exceptionInfoSourceSpan = Nothing , exceptionInfoInner = [] } - --- | Determine whether the debugger is currently stopped because of an --- exception (as opposed to a breakpoint). -currentlyStoppedOnException :: Debugger Bool -currentlyStoppedOnException = do - resumes <- GHC.getResumeContext - return $ case resumes of - [] -> False - r:_ -> isNothing (GHC.resumeBreakpointId r) diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -5,6 +5,7 @@ module GHC.Debugger.Stopped.Variables where import Control.Monad.Reader +import qualified Colog.Core as Logger import GHC import GHC.Types.FieldLabel @@ -12,7 +13,10 @@ import GHC.Types.Var import GHC.Runtime.Eval import GHC.Core.DataCon +import GHC.Core.FamInstEnv (topNormaliseType_maybe, emptyFamInstEnvs) import GHC.Core.TyCo.Rep +import GHC.Core.Reduction (Reduction(..)) +import GHC.Tc.Instance.Family (tcGetFamInstEnvs, FamInstEnvs) import qualified GHC.Runtime.Debugger as GHCD import qualified GHC.Runtime.Heap.Inspect as GHCI @@ -25,8 +29,8 @@ -- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the -- value of the thing (as in @True = :force@, @False = :print@) -tyThingToVarInfo :: TyThing -> Debugger VarInfo -tyThingToVarInfo t = case t of +tyThingToVarInfo :: FamInstEnvs -> TyThing -> Debugger VarInfo +tyThingToVarInfo fam_envs t = case t of AConLike c -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables ATyCon c -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables ACoAxiom c -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables @@ -40,14 +44,14 @@ AnId i -> do let key = FromId i term <- obtainTerm key - termToVarInfo key term + termToVarInfo fam_envs key term -- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term' -- -- This is used to come up with terms for the fields of an already `seq`ed -- variable which was expanded. -termVarFields :: TermKey -> Term -> Debugger VarFields -termVarFields top_key top_term = do +termVarFields :: FamInstEnvs -> TermKey -> Term -> Debugger VarFields +termVarFields fam_envs top_key top_term = do vcVarFields <- debugFieldsTerm top_term @@ -56,7 +60,7 @@ Just fls -> do let keys = map (\(f_name, f_term) -> FromCustomTerm top_key f_name f_term) fls - VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys + VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys -- The general case _ -> case top_term of @@ -67,61 +71,60 @@ -- Use indexed fields [] -> do let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConRepArgTys dc) - VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys + VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys -- Is a record data con, -- Use field labels dataConFields -> do let mkPath ix Nothing = FromPath top_key (PositionalIndex ix) mkPath ix (Just fld) = FromPath top_key (LabeledField ix (flSelector fld)) keys = zipWith mkPath [1..] ((Nothing <$ dataConOtherTheta dc) ++ (map Just dataConFields)) - VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys + VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo fam_envs k) keys NewtypeWrap{dc=Right dc, wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do case dataConFieldLabels dc of [] -> do let key = FromPath top_key (PositionalIndex 1) - wvi <- obtainTerm key >>= termToVarInfo key + wvi <- obtainTerm key >>= termToVarInfo fam_envs key return (VarFields [wvi]) [fld] -> do let key = FromPath top_key (LabeledField 1 (flSelector fld)) - wvi <- obtainTerm key >>= termToVarInfo key + wvi <- obtainTerm key >>= termToVarInfo fam_envs key return (VarFields [wvi]) _ -> error "unexpected number of Newtype fields: larger than 1" RefWrap{wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do let key = FromPath top_key (PositionalIndex 1) - wvi <- obtainTerm key >>= termToVarInfo key + wvi <- obtainTerm key >>= termToVarInfo fam_envs key return (VarFields [wvi]) _ -> return (VarFields []) -- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds -termToVarInfo :: TermKey -> Term -> Debugger VarInfo -termToVarInfo key term0 = do +-- The @FamInstEnvs@ is used to look through newtypes and type families when checking if suspensions are of function type. +termToVarInfo :: FamInstEnvs -> TermKey -> Term -> Debugger VarInfo +termToVarInfo fam_envs key term0 = do -- Make a VarInfo for a term let ty = GHCI.termType term0 - -- Check for function types explicitly since they seem to always match Suspension - -- but should not be shown as thunks in the UI. - checkFn (FunTy _ _ _ _) = True - checkFn (ForAllTy _ t) = checkFn t - checkFn _ = False - isFn = checkFn ty - varName <- display key varType <- display ty case term0 of + t | Suspension{} <- unwrapNewtype t, isFunctionType ty -> do + return VarInfo + { varName + , varType + , varValue = " :: " ++ varType + , varRef = NoVariables + , isThunk = False + } + -- The simple case: The term is a a thunk... Suspension{} -> do return VarInfo { varName , varType - , varValue = if isFn - then " :: " ++ varType - else "_" - , varRef = if isFn - then NoVariables - else SpecificVariable key -- allows forcing the thunk - , isThunk = not isFn + , varValue = "_" + , varRef = SpecificVariable key -- allows forcing the thunk + , isThunk = True } -- Otherwise, try to apply and decode a custom 'DebugView', or default to @@ -182,8 +185,45 @@ Prim{} -> False NewtypeWrap{} -> True RefWrap{} -> True - Term{subTerms} -> not $ null subTerms + Term{subTerms} -> not $ null $ subTerms + -- Check for function types explicitly since they seem to always match Suspension + -- but should not be shown as thunks in the UI. + isFunctionType = \case + (FunTy _ _ _ _) -> True + (ForAllTy _ t) -> isFunctionType t + (topNormaliseType_maybe fam_envs -> Just Reduction{..}) + -> isFunctionType reductionReducedType + _ -> False + -- FIXME: couldn't find test case where this is needed. + unwrapNewtype (NewtypeWrap {wrapped_term}) = unwrapNewtype wrapped_term + unwrapNewtype x = x +-- | Thin wrapper around @tcGetFamInstEnvs@, using @runTcInteractive@ +getFamInstEnvs' :: Debugger FamInstEnvs +getFamInstEnvs' = do + hsc_env <- getSession + (err_msgs, res) <- liftIO $ runTcInteractive hsc_env $ tcGetFamInstEnvs + case res of + Just fam_envs -> pure fam_envs + Nothing -> do + logSDoc Logger.Debug + $ text "Couldn't lookup FamInstEnvs to normalise type for VarInfo," + <+> text "using empty ones." + $$ ppr err_msgs + return emptyFamInstEnvs + +pprTerm :: Term -> SDoc +pprTerm t = case t of + Term{dc,subTerms} -> annotate "T:" $ + either text ppr dc <+> ppr (map pprTerm subTerms) + Prim{valRaw} -> annotate "P:" $ ppr valRaw + Suspension{bound_to,ctype} -> annotate "S:" $ ppr bound_to <+> text (show ctype) + NewtypeWrap{dc,wrapped_term} -> + annotate "N:" $ either text ppr dc <+> pprTerm wrapped_term + RefWrap{wrapped_term} -> annotate "R:" $ pprTerm wrapped_term + where + annotate tag d = parens $ text tag <+> ppr (ty t) <+> text "∋" <+> d + -- | Forces a term to WHNF -- -- The term is updated in the cache at the given key. @@ -191,4 +231,3 @@ forceTerm term = do hsc_env <- getSession liftIO $ seqTerm hsc_env term - diff --git a/haskell-debugger/GHC/Debugger/Utils/Orphans.hs b/haskell-debugger/GHC/Debugger/Utils/Orphans.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Utils/Orphans.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Debugger.Utils.Orphans where + +import GHC.Debugger.View.Class +import GHC.Data.FastString + +instance DebugView FastString where + debugValue t = simpleValue (unpackFS t) False + debugFields _ = pure (VarFields []) diff --git a/hdb/Development/Debug/Adapter.hs b/hdb/Development/Debug/Adapter.hs --- a/hdb/Development/Debug/Adapter.hs +++ b/hdb/Development/Debug/Adapter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} module Development.Debug.Adapter where import Control.Concurrent.MVar @@ -12,6 +13,7 @@ import DAP import qualified GHC import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference) +import Network.Socket (PortNumber) type DebugAdaptor = Adaptor DebugAdaptorState Request type DebugAdaptorCont = Adaptor DebugAdaptorState () @@ -24,22 +26,18 @@ -- - The debugger main worker writes to this MVar responses (and, for now, events too) -- - The handler worker reads from this MVar and writes them to the client with the 'Adapter'. data DebugAdaptorState = DAS - { syncRequests :: MVar D.Command + { syncRequests :: MVar D.Command , syncResponses :: MVar D.Response - , nextFreshId :: !Int + , nextFreshId :: !Int , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet , stackFrameMap :: IM.IntMap StackFrameIx , variablesMap :: IM.IntMap VariablesIx - , entryFile :: FilePath - , entryPoint :: String - , entryArgs :: [String] - , projectRoot :: FilePath - , syncProxyIn :: Chan BS.ByteString - -- ^ Read input to the debuggee from the proxy - , syncProxyOut :: Chan BS.ByteString - -- ^ Write output from the debuggee to the proxy - , syncProxyErr :: Chan BS.ByteString - -- ^ Write stderr from the debuggee to the proxy + , entryFile :: FilePath + , entryPoint :: String + , entryArgs :: [String] + , projectRoot :: FilePath + , runInTerminalProc :: RunInTerminalProc + -- ^ Potentially a process launched via 'runInTerminal'. } type BreakpointId = Int @@ -50,9 +48,56 @@ data VariablesIx = VariablesIx StackFrameIx D.VariableReference instance MonadFail DebugAdaptor where - fail a = error a - -- TODO: PROPER ERROR HANDLING with termination, possibly delete this instance - -- use: exitWithMsg. + fail a = sendError (ErrorMessage (T.pack a)) Nothing + +-------------------------------------------------------------------------------- +-- * Run in terminal +-------------------------------------------------------------------------------- + +-- | A process launched via 'runInTerminal', which is attached to a user's terminal +data RunInTerminalProc + -- | We're not using 'runInTerminal', so we didn't request the DAP client to + -- launch a process on the user's terminal. + = NoRunInTerminal + + -- | Instead of launching the external interpreter ourselves, we requested + -- the DAP client to launch the external interpreter process + | RunExternalInterpreterInTerminal + { extInterpPort :: PortNumber + -- ^ The port on which the external interpreter is running. + -- + -- The external interpreter is only connected to a port when we launch + -- it ourselves through 'runInTerminal'. + -- + -- When 'NoRunInTerminal' but using external-interpreter, we'll still + -- launch the external interpreter but in the default GHC way using the + -- file descriptors directly. + } + + -- | We launched @hdb proxy ...@ on the user's terminal. + -- + -- This process will forward all input the user types into the + -- debugger/debuggee process and be forwarded the debuggee's output to print. + -- + -- We should always prefer to launch 'RunExternalInterpreterInTerminal' + -- directly, but is not possible if using the internal interpreter. + -- + -- See 'Development.Debug.Adapter.Proxy' for more details on @hdb proxy@. + | RunProxyInTerminal + { syncProxyIn :: Chan BS.ByteString + -- ^ Read input to the debuggee from the proxy + , syncProxyOut :: Chan BS.ByteString + -- ^ Write output from the debuggee to the proxy + , syncProxyErr :: Chan BS.ByteString + -- ^ Write stderr from the debuggee to the proxy + , proxyClientReady :: MVar () + -- ^ Wait for the runInTerminal proxy client to connect to the proxy + -- server (#95). + -- + -- Prevent a race where the debug session finishes before the + -- 'runInTerminal' proxy has a chance to connect, so when it does + -- finally try to connect it crashes. + } -------------------------------------------------------------------------------- -- * Utilities diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs --- a/hdb/Development/Debug/Adapter/Breakpoints.hs +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -7,6 +7,7 @@ import Text.Read import Control.Monad import Data.Maybe +import System.FilePath ((), normalise) import qualified GHC @@ -63,6 +64,7 @@ } (readMaybe @Int =<< (T.unpack <$> DAP.sourceBreakpointHitCondition bp)) (T.unpack <$> DAP.sourceBreakpointCondition bp) + (T.unpack <$> DAP.sourceBreakpointLogMessage bp) registerBreakFound bf sendSetBreakpointsResponse (concat breaks) @@ -84,6 +86,7 @@ FunctionBreak { function = T.unpack $ DAP.functionBreakpointName bp } (readMaybe @Int =<< (T.unpack <$> DAP.functionBreakpointHitCondition bp)) (T.unpack <$> DAP.functionBreakpointCondition bp) + Nothing registerBreakFound bf sendSetFunctionBreakpointsResponse (concat breaks) @@ -101,11 +104,11 @@ let breakOnError = BREAK_ON_ERROR `elem` setExceptionBreakpointsArgumentsFilters when breakOnExceptions $ do - DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing) + DidSetBreakpoint _ <- sendSync (SetBreakpoint OnExceptionsBreak Nothing Nothing Nothing) pure () when breakOnError $ do - DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing) + DidSetBreakpoint _ <- sendSync (SetBreakpoint OnUncaughtExceptionsBreak Nothing Nothing Nothing) pure () sendSetExceptionBreakpointsResponse @@ -153,8 +156,9 @@ -- TODO: Handles sourceReferences too fileFromSourcePath :: Source -> DebugAdaptor FilePath fileFromSourcePath source = do + prjRoot <- projectRoot <$> getDebugSession let file = T.unpack $ fromMaybe (error "sourceReference unsupported") $ sourcePath source - return file + return $ normalise $ prjRoot file diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb/Development/Debug/Adapter/Evaluation.hs --- a/hdb/Development/Debug/Adapter/Evaluation.hs +++ b/hdb/Development/Debug/Adapter/Evaluation.hs @@ -57,7 +57,7 @@ sendEvaluateResponse (simpleEvalResp (T.pack e) (T.pack "")) EvalException {resultVal, resultType} -> sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType)) - EvalCompleted{resultVal, resultType, resultStructureRef} -> do + EvalCompleted{resultVal, resultType, resultSourceKind, resultStructureRef} -> do varIx <- case resultStructureRef of NoVariables -> pure 0 LocalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable" @@ -73,11 +73,16 @@ } pure varId + let orIfNoResult !x !y + | Just IsStmt <- resultSourceKind = y + | resultType == "()" = y + | otherwise = x + sendEvaluateResponse EvaluateResponse - { evaluateResponseResult = T.pack resultVal - , evaluateResponseType = T.pack resultType + { evaluateResponseResult = T.pack resultVal `orIfNoResult` T.empty + , evaluateResponseType = T.pack resultType `orIfNoResult` T.empty , evaluateResponsePresentationHint = Nothing - , evaluateResponseVariablesReference = varIx + , evaluateResponseVariablesReference = varIx `orIfNoResult` 0 , evaluateResponseNamedVariables = Nothing , evaluateResponseIndexedVariables = Nothing , evaluateResponseMemoryReference = Nothing @@ -127,4 +132,3 @@ = maybe [] IS.toList (M.lookup bid breakpointMap) , stoppedEventThreadId = Just $ remoteThreadIntRef breakThread } - diff --git a/hdb/Development/Debug/Adapter/Exit.hs b/hdb/Development/Debug/Adapter/Exit.hs --- a/hdb/Development/Debug/Adapter/Exit.hs +++ b/hdb/Development/Debug/Adapter/Exit.hs @@ -22,93 +22,26 @@ -- * @'destroyDebugSession'@ kills all threads started for this session with @'registerNewDebugSession'@. module Development.Debug.Adapter.Exit where -import DAP -import Data.Function -import System.IO -import Control.Monad +import Control.Monad.Except import Control.Monad.IO.Class -import Control.Exception -import Control.Exception.Context -import qualified Data.Text as T -import qualified Data.Text.IO as T - +import DAP import Development.Debug.Adapter -import qualified Development.Debug.Adapter.Output as Output -- | Command terminate (1a) -- --- Terminate the debuggee gracefully. +-- Terminate the *debuggee* gracefully commandTerminate :: DebugAdaptor () commandTerminate = do - -- Terminate debuggee and sends acknowledgment. - -- TODO: Terminate event instead of destroy session? - -- DidTerminate <- sendInterleaved TerminateProcess sendTerminateResponse - destroyDebugSession + destroyDebugSession -- kills debugger GHC session (which handles stopping the debuggee ext-interp too) sendTerminateResponse - exitCleanly Nothing + sendTerminatedEvent (TerminatedEvent False) -- we're done debugging now! -- | Command disconnect (1b) -- -- Terminate the debuggee (and any child processes) forcefully. commandDisconnect :: DebugAdaptor () commandDisconnect = do - destroyDebugSession + -- kills debugger GHC session (which handles stopping the debuggee ext-interp too) + -- ignore error if session has already been destroyed (e.g. client sends disconnect after terminate) + destroyDebugSession `catchError` \ e -> liftIO $ putStrLn ("terminateSessionCleanly: ignoring missing session: " ++ show e) sendDisconnectResponse - exitCleanly Nothing - ---- Exit Cleanly --------------------------------------------------------------- - --- | Outputs a message notification ('Output.important'), sends a terminated --- event, destroys the debug session, and dies. --- --- ::WARNING:: --- --- This function should not be called if the debugsession with the debugger --- threads haven't yet been registered because it WILL block on the call to --- @'destroyDebugSession'@. -exitCleanupWithMsg - :: Handle - -- ^ Handle to finalize reading as OutputEvents before exiting (but after - -- killing the output thread with @destroyDebugSession@) - -> String - -- ^ Error message, logged with notification - -> DebugAdaptor () -exitCleanupWithMsg final_handle msg = do - destroyDebugSession -- kill all session threads (including the output thread) - has_data <- hReady final_handle & liftIO - when has_data $ do - -- get all pending output from GHC - c <- T.hGetContents final_handle & liftIO - Output.neutral c - exitWithMsg msg - --- | Logs the error to the debug console and sends a terminate event -exitWithMsg :: String -> DebugAdaptor a -exitWithMsg msg = do - Output.important (T.pack msg) - exitCleanly (Just msg) - -exitCleanly :: Maybe String -> DebugAdaptor a -exitCleanly mm = do - - sendTerminatedEvent (TerminatedEvent False) - - -- We exit here to guarantee the process is killed when - -- terminated. Important! We want a new server process per - -- session, which means at the end we must kill the server. - liftIO $ do - case mm of - Nothing -> throwIO TerminateServer - Just em -> do - hPutStrLn stderr em - throwIO TerminateServer - ---- Utils ---------------------------------------------------------------------- - --- | Display an exception with its context -displayExceptionWithContext :: SomeException -> String -displayExceptionWithContext ex = do - case displayExceptionContext (someExceptionContext ex) of - "" -> displayException ex - cx -> displayException ex ++ "\n\n" ++ cx - diff --git a/hdb/Development/Debug/Adapter/Exit/Helpers.hs b/hdb/Development/Debug/Adapter/Exit/Helpers.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Exit/Helpers.hs @@ -0,0 +1,47 @@ +module Development.Debug.Adapter.Exit.Helpers where + +import DAP +import Data.Function +import System.IO +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Development.Debug.Adapter +import qualified Development.Debug.Adapter.Output as Output + +--- Exit Cleanly --------------------------------------------------------------- + +-- | Outputs a message notification ('Output.important'), sends a terminated +-- event, destroys the debug session, and dies. +-- +-- ::WARNING:: +-- +-- This function should not be called if the debugsession with the debugger +-- threads haven't yet been registered because it WILL block on the call to +-- @'destroyDebugSession'@. +exitCleanupWithMsg + :: Handle + -- ^ Handle to finalize reading as OutputEvents before exiting (but after + -- killing the output thread with @destroyDebugSession@) + -> String + -- ^ Error message, logged with notification + -> DebugAdaptor () +exitCleanupWithMsg final_handle msg = do + has_data <- hReady final_handle & liftIO + when has_data $ do + -- get all pending output from GHC + c <- T.hGetContents final_handle & liftIO + Output.neutral c + terminateWithError msg + +-- | Abruptly terminate a session in the middle of a Request/Response cycle by +-- sending a Terminated event (meaning the debug session is over), destroying +-- the debug session threads, and replying to the response with 'ErrorResponse' +terminateWithError :: String -> DebugAdaptor () +terminateWithError msg = do + Output.important (T.pack msg) + destroyDebugSession + sendTerminatedEvent (TerminatedEvent False) + sendError (ErrorMessage (T.pack msg)) Nothing diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -9,6 +9,11 @@ -- | TODO: This module should be called Launch. module Development.Debug.Adapter.Init where +#if !MIN_VERSION_ghc(9,15,0) +-- no longer needs to be imported from here in 9.15 +import GHC.Conc.Sync (labelThread) +#endif + import GHC.IO.Handle import System.Process import qualified Data.ByteString as BS @@ -16,17 +21,18 @@ import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import qualified System.Process as P +import Control.Exception (displayExceptionWithInfo) import Control.Monad.Except import Control.Monad.Trans import Data.Function import Data.Functor import Data.Maybe +import Data.UUID.V4 qualified as UUID import System.IO import GHC.IO.Encoding import Control.Monad.Catch -import Control.Exception (SomeAsyncException, throwIO, IOException) +import Control.Exception (throwIO, IOException) import Control.Concurrent -import GHC.Conc.Sync (labelThread) import Control.Monad import Data.Aeson as Aeson import GHC.Generics @@ -35,7 +41,6 @@ import Data.Functor.Contravariant import Development.Debug.Adapter -import Development.Debug.Adapter.Exit import Colog.Core as Logger import qualified Development.Debug.Adapter.Output as Output @@ -49,6 +54,10 @@ import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup +import Development.Debug.Adapter.Proxy +import System.Environment +import Network.Socket (socketPort) +import qualified Network.Socket as Socket -------------------------------------------------------------------------------- -- * Client @@ -80,20 +89,17 @@ data DAPLog = DAPSessionSetupLog (WithSeverity SessionSetupLog) | DAPDebuggerLog Debugger.DebuggerLog + | RunProxyServerLog (WithSeverity T.Text) -------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- - --- | Exception type for when hie-bios initialization fails -newtype InitFailed = InitFailed String deriving Show - -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise initDebugger :: LogAction IO DAPLog -> Bool -> Bool - -> LaunchArgs -> ExceptT InitFailed DebugAdaptor () + -> LaunchArgs -> DebugAdaptor () initDebugger l supportsRunInTerminal preferInternalInterpreter LaunchArgs{ __sessionId , projectRoot = givenRoot @@ -104,12 +110,9 @@ } = do syncRequests <- liftIO newEmptyMVar syncResponses <- liftIO newEmptyMVar - syncProxyIn <- liftIO newChan - syncProxyOut <- liftIO newChan - syncProxyErr <- liftIO newChan entryFile <- case entryFileMaybe of - Nothing -> throwError $ InitFailed "Missing \"entryFile\" key in debugger configuration" + Nothing -> throwError ("Missing \"entryFile\" key in debugger configuration", Nothing) Just ef -> pure ef projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot @@ -135,66 +138,127 @@ | otherwise -> mempty liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case - Left e -> throwError $ InitFailed e - Right (Left e) -> lift $ exitWithMsg e + Left e -> throwError (ErrorMessage (T.pack e), Nothing) + Right (Left e) -> throwError (ErrorMessage (T.pack e), Nothing) Right (Right flags) -> do - -- Create the stdin handle for the external interpreter - (readExternalIntStdin, writeExternalIntStdin) <- liftIO P.createPipe - liftIO $ do - hSetBuffering readExternalIntStdin LineBuffering - hSetBuffering writeExternalIntStdin NoBuffering - hSetEncoding readExternalIntStdin utf8 - hSetEncoding writeExternalIntStdin utf8 - let nextFreshId = 0 - breakpointMap = mempty - stackFrameMap = mempty - variablesMap = mempty - defaultRunConf = Debugger.RunDebuggerSettings - { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap - , supportsANSIHyperlinks = False -- VSCode does not support this - , preferInternalInterpreter - , externalInterpreterStdinStream = UseHandle readExternalIntStdin - } + let + nextFreshId = 0 + breakpointMap = mempty + stackFrameMap = mempty + variablesMap = mempty - finished_init <- liftIO $ newEmptyMVar + mkRunInTerminalProc + | not supportsRunInTerminal + = pure NoRunInTerminal + | not preferInternalInterpreter + = do + sock <- openSocketAvailablePort + port <- socketPort sock + -- Close socket again to make sure we can open the server socket + -- later again. + Socket.close sock + pure RunExternalInterpreterInTerminal + { extInterpPort = port + } + | otherwise + = do + (syncProxyIn, syncProxyOut, syncProxyErr) + <- (,,) <$> newChan <*> newChan <*> newChan + proxyClientReady <- newEmptyMVar + pure RunProxyInTerminal{..} + runInTerminalProc <- liftIO mkRunInTerminalProc + dbgLog <- liftIO $ - createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) + createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc - let absEntryFile = normalise $ projectRoot entryFile - lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..} - [ debuggerThread dbgLog finished_init projectRoot flags - extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses + (runInTerminalThreads, afterRegisterActions) <- + mkRunInTerminalThreads l runInTerminalProc preferInternalInterpreter + let + defaultRunConf = Debugger.RunDebuggerSettings + { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap + , supportsANSIHyperlinks = False -- VSCode does not support this + , preferInternalInterpreter + , externalInterpreterCustomProc = case runInTerminalProc of + RunExternalInterpreterInTerminal{extInterpPort} + -> Right extInterpPort + _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin + } + absEntryFile = normalise $ projectRoot entryFile + daState = DAS{entryFile=absEntryFile,..} + + sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId + registerNewDebugSession sessionId daState $ + [ debuggerThread dbgLog flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses , \withAdaptor -> forwardHandleToLogger readDAPOutput $ LogAction (\msg -> withAdaptor (Output.neutral msg)) - - -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, - -- but only if we're using the internal interpreter! - , if preferInternalInterpreter then stdinForwardThread supportsRunInTerminal syncProxyIn else mempty - , if preferInternalInterpreter then stdoutCaptureThread supportsRunInTerminal syncProxyOut else mempty - , if preferInternalInterpreter then stderrCaptureThread supportsRunInTerminal syncProxyErr else mempty - , if preferInternalInterpreter - then mempty - else const $ do - -- forward proxy in to external interpreter stdin - forever $ do - i <- readChan syncProxyIn - -- 3. Write to write-end of the pipe - BS.hPut writeExternalIntStdin i >> hFlush writeExternalIntStdin ] + ++ + runInTerminalThreads - -- Do not return until the initialization is finished - liftIO (takeMVar finished_init) >>= \case - Right () -> pure () - Left e -> do - -- The process terminates cleanly with an error code (probably exit failure = 1) - -- This can happen if compilation fails and the compiler exits cleanly. - -- - -- Instead of signalInitialized, respond with error and exit. - lift $ exitCleanupWithMsg readDAPOutput e + afterRegisterActions +-- | Additional threads to register for this session depending on the process +-- we're running through `runInTerminal` (see 'RunInTerminalProc'). +mkRunInTerminalThreads + :: LogAction IO DAPLog + -> RunInTerminalProc + -> Bool -- ^ Use internal interpreter + -> DebugAdaptor ([(DebugAdaptorCont () -> IO ()) -> IO ()], DebugAdaptor ()) + -- ^ Threads to register in this debug session and additional commands to + -- run after registering the session. + +mkRunInTerminalThreads _ NoRunInTerminal useInternalInterp + -- Not using the terminal proxy, but we still want to output our own + -- stdout/err (from the internal interpreter) as console events. + | True <- useInternalInterp + = pure ([ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ], pure ()) + + | otherwise + = pure ([], pure ()) + +mkRunInTerminalThreads _ RunExternalInterpreterInTerminal{..} _ + -- No additional bookkeeping is needed in this case because GHC will + -- naturally have to wait for the external interpreter in order to start execution + = do + thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode + pure ([], + sendRunInTerminalReverseRequest + RunInTerminalRequestArguments + { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated + , runInTerminalRequestArgumentsTitle = Nothing + , runInTerminalRequestArgumentsCwd = "" + , runInTerminalRequestArgumentsArgs = + [T.pack thisProg, "external-interpreter", "--port", T.pack (show extInterpPort)] + , runInTerminalRequestArgumentsEnv = Nothing + , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False + }) + +mkRunInTerminalThreads l RunProxyInTerminal{..} _ + = do + (serverPort, serverProxyThread) <- + mkServerSideHdbProxy (contramap RunProxyServerLog l) + syncProxyIn syncProxyOut syncProxyErr proxyClientReady + + pure ( + [ ($ serverProxyThread) + + -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, + -- but only because we're using the internal interpreter! + , stdinForwardThread syncProxyIn + , stdoutCaptureThread (Just syncProxyOut) + , stderrCaptureThread (Just syncProxyErr) + ], + + -- When using the internal interpreter and 'runInTerminal' is supported + -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the + -- `hdb proxy` attached to the user's terminal. The proxy forwards + -- input/output from the user terminal to the debugger+debuggee shared process + sendRunProxyInTerminal serverPort + ) + -- | The main debugger thread launches a GHC.Debugger session. -- -- Then, forever: @@ -204,17 +268,7 @@ -- -- Concurrently, it reads from the process's stderr forever and outputs it through OutputEvents. -- --- Notes: --- --- (CWD): --- It's necessary for the GHC session to be run in the project root. --- We do this by setting the current directory on initialize. --- This sets the global CWD for this process, disallowing multiple sessions --- at the same, but that's OK because we currently only support --- single-session mode. Each new session gets a new debugger process. debuggerThread :: LogAction IO Debugger.DebuggerLog - -> MVar (Either String ()) -- ^ To signal when initialization is complete. - -> FilePath -- ^ Working directory for GHC session -> HieBiosFlags -- ^ GHC Invocation flags -> [String] -- ^ Extra ghc args -> FilePath @@ -224,10 +278,7 @@ -> (DebugAdaptorCont () -> IO ()) -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'. -> IO () -debuggerThread l finished_init workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do - - -- See Notes (CWD) above - setCurrentDirectory workDir +debuggerThread l HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do -- Log haskell-debugger invocation withAdaptor $ @@ -236,33 +287,23 @@ "units: " <> unwords units <> "\n" <> "args: " <> unwords (ghcInvocation ++ extraGhcArgs) - catches - (do - Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do - liftIO $ do - tid <- myThreadId - labelThread tid "Main Debugger Thread" - liftIO $ signalInitialized (Right ()) - forever $ do + Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do + liftIO $ do + tid <- myThreadId + labelThread tid "Main Debugger Thread" + let loop = do req <- takeMVar requests & liftIO resp <- (Debugger.execute req <&> Right) - `catch` \(e :: SomeException) -> - pure (Left (displayExceptionWithContext e)) - either bad reply resp - ) - [ Handler $ \(e::SomeAsyncException) -> do - throwIO e - , Handler $ \(e::SomeException) -> do - signalInitialized (Left (displayException e)) - ] - - where - signalInitialized - = putMVar finished_init - reply = liftIO . putMVar replies - bad m = liftIO $ do - hPutStrLn stderr m - putMVar replies (Aborted ("Aborted debugger thread: " ++ m)) + `catch` \(e :: SomeException) -> do + pure (Left (displayExceptionWithInfo e)) + case resp of + Right x -> do + liftIO (putMVar replies x) + loop + Left m -> + -- don't loop in this case! just exit. + liftIO $ putMVar replies (Aborted ("Aborted debugger thread: " ++ m)) + loop -------------------------------------------------------------------------------- -- * Logging @@ -287,9 +328,9 @@ :: LogAction IO DAPLog -> LogAction IO T.Text -- ^ Logger that writes to to DAP output -> Handle -- ^ Handle to DAP output - -> (Bool, Chan BS.ByteString, Chan BS.ByteString) -- ^ Proxy channels, and whether is supported + -> RunInTerminalProc -> IO (LogAction IO Debugger.DebuggerLog) -createDebuggerLogger l dapLogger writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) = do +createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do return $ -- (1) (all output is logged to normal logger) contramap DAPDebuggerLog l <> @@ -300,56 +341,65 @@ dapLogger <& T.pack (show msg) Debugger.GHCLog logflags msg_class srcSpan msg -> defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg - Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger syncProxyOut txt - Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger syncProxyErr txt + Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger msyncProxyOut txt + Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger msyncProxyErr txt _ -> pure () -- don't log other messages, already logged to (1) ) where - debuggeeOut l' proxyChan txt = do + debuggeeOut l' mproxyChan txt = do -- (2) l' <& txt -- (3) - when supportsRunInTerminal $ - writeChan proxyChan $ - T.encodeUtf8 (txt <> "\n") + case mproxyChan of + Nothing -> pure () + Just proxyChan -> + writeChan proxyChan $ + T.encodeUtf8 (txt <> "\n") + (msyncProxyOut, msyncProxyErr) + | RunProxyInTerminal{syncProxyOut, syncProxyErr} <- runInTerminalProc + = (Just syncProxyOut, Just syncProxyErr) + | otherwise + = (Nothing, Nothing) + -------------------------------------------------------------------------------- -- * Capturing stdout, stderr, and writing to self stdin -------------------------------------------------------------------------------- -- | Hijack the current process stdin and forward to it the messages from the given channel -stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () -stdinForwardThread runInTerminal syncIn _withAdaptor = do +stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdinForwardThread syncIn _withAdaptor = do tid <- myThreadId labelThread tid "Stdin Forward Thread" - when runInTerminal $ do - -- We need to hijack stdin to write to it - -- 1. Create a new pipe from writeEnd->readEnd - (readEnd, writeEnd) <- createPipe + -- We need to hijack stdin to write to it - -- 2. Substitute the read-end of the pipe by stdin - _ <- hDuplicateTo readEnd stdin - hClose readEnd -- we'll never need to read from readEnd + -- 1. Create a new pipe from writeEnd->readEnd + (readEnd, writeEnd) <- createPipe - forever $ do - i <- readChan syncIn - -- 3. Write to write-end of the pipe - BS.hPut writeEnd i >> hFlush writeEnd + -- 2. Substitute the read-end of the pipe by stdin + _ <- hDuplicateTo readEnd stdin + hClose readEnd -- we'll never need to read from readEnd + forever $ do + i <- readChan syncIn + -- 3. Write to write-end of the pipe + BS.hPut writeEnd i >> hFlush writeEnd + -- | This thread captures stdout from the debuggee and sends it to the client. -- NOTE, redirecting the stdout handle is a process-global operation. So this thread -- will capture ANY stdout the debuggee emits. Therefore you should never directly -- write to stdout, but always write to the appropiate handle. -stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () -stdoutCaptureThread runInTerminal syncOut withAdaptor = do +stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stdoutCaptureThread msyncOut withAdaptor = do tid <- myThreadId - labelThread tid "Stdin Capture Thread" + labelThread tid "Stdout Capture Thread" withInterceptedStdout $ \_ interceptedStdout -> do forever $ do line <- liftIO $ T.hGetLine interceptedStdout - when runInTerminal $ - writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") + case msyncOut of + Nothing -> pure () + Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") -- Always output to Debug Console catch @@ -358,15 +408,16 @@ throwIO (FailedToWriteToAdaptor line)) -- | Like 'stdoutCaptureThread' but for stderr -stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () -stderrCaptureThread runInTerminal syncErr withAdaptor = do +stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stderrCaptureThread msyncErr withAdaptor = do tid <- myThreadId labelThread tid "Stderr Capture Thread" withInterceptedStderr $ \_ interceptedStderr -> do forever $ do line <- liftIO $ T.hGetLine interceptedStderr - when runInTerminal $ - writeChan syncErr $ T.encodeUtf8 (line <> "\n") + case msyncErr of + Nothing -> pure () + Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n") -- Always output to Debug Console catch diff --git a/hdb/Development/Debug/Adapter/Interface.hs b/hdb/Development/Debug/Adapter/Interface.hs --- a/hdb/Development/Debug/Adapter/Interface.hs +++ b/hdb/Development/Debug/Adapter/Interface.hs @@ -9,7 +9,6 @@ import GHC.Debugger.Interface.Messages as D import Development.Debug.Adapter -import Development.Debug.Adapter.Exit import qualified Development.Debug.Adapter.Output as Output -- | Synchronously send a command to the debugger and await a response @@ -30,6 +29,8 @@ handleAbort :: Response -> DebugAdaptor Response handleAbort (Aborted e) = do Output.console (T.pack e) - exitCleanly (Just e) + sendTerminatedEvent (TerminatedEvent False) + destroyDebugSession -- kill this debu session's threads + -- reply still in thia connection with "ErrorResponse" to pending request + sendError (ErrorMessage (T.pack e)) Nothing handleAbort r = return r - diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs --- a/hdb/Development/Debug/Adapter/Proxy.hs +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -1,11 +1,26 @@ -{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies #-} +{-# LANGUAGE BlockArguments, OverloadedStrings, DerivingStrategies, OrPatterns #-} +{-# LANGUAGE NondecreasingIndentation #-} -- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and --- is displayed in a terminal in the DAP client using 'runInTerminal' +-- is displayed in a terminal in the DAP client using 'runInTerminal'. +-- +-- Note: the proxy program is only launched when 'runInTerminal' is supported +-- and we're using the internal interpreter (--internal-interpreter). +-- +-- If the external interpreter is being used (the default), we launch the +-- external interpreter directly with 'runInTerminal' and don't need the proxy +-- at all. module Development.Debug.Adapter.Proxy - ( serverSideHdbProxy + ( mkServerSideHdbProxy , runInTerminalHdbProxy + , sendRunProxyInTerminal + , openSocketAvailablePort ) where +#if !MIN_VERSION_ghc(9,15,0) +-- no longer needs to be imported in 9.15 +import GHC.Conc.Sync (labelThread) +#endif + import DAP import Control.Concurrent.Async @@ -17,7 +32,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Concurrent -import GHC.Conc.Sync (labelThread) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T @@ -29,6 +43,7 @@ import Colog.Core import Development.Debug.Adapter +import qualified Control.Exception as E -- | Fork a new thread to run the server-side of the proxy. -- @@ -40,25 +55,21 @@ -- 2. In a loop, -- 2.1 Read stdin from the socket and push it to a Chan -- 2.1 Read from a stdout Chan and write to the socket -serverSideHdbProxy :: LogAction IO (WithSeverity T.Text) +mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text) + -> Chan BS8.ByteString + -> Chan BS8.ByteString + -> Chan BS8.ByteString -> MVar () - -> DebugAdaptor () -serverSideHdbProxy l client_conn_signal = do - DAS { syncProxyIn = dbIn - , syncProxyOut = dbOut - , syncProxyErr = dbErr } <- getDebugSession - - sock <- liftIO $ do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } - addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") - -- Bind on "0" to let the OS pick a free port - openTCPServerSocket addr + -> Adaptor DebugAdaptorState r (PortNumber, Adaptor DebugAdaptorState s ()) +mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = do + sock <- liftIO $ openSocketAvailablePort port <- liftIO $ socketPort sock - fwd_thr <- liftIO $ async $ ignoreIOException $ do + return $ (port,) $ liftIO $ do + ignoreIOException $ do myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server" - runTCPServerWithSocket sock $ \scket -> do + runTCPServerWithSocket' sock $ \scket -> do infoMsg (T.pack $ "Connected to client on port " ++ show port ++ "...!") putMVar client_conn_signal () -- signal ready (see #95) @@ -67,16 +78,14 @@ (race_ (-- Read stdout from chan and write to socket ignoreIOException $ do - tid <- myThreadId - labelThread tid "Debug/Adapter/Proxy: Forward stdout" + labelMe "Debug/Adapter/Proxy: Forward stdout" forever $ do bs <- readChan dbOut debugMsg (T.pack $ "Writing to socket: " ++ BS8.unpack bs) NBS.sendAll scket bs) (-- Read stderr from chan and write to socket ignoreIOException $ do - tid <- myThreadId - labelThread tid "Debug/Adapter/Proxy: Forward stderr" + labelMe "Debug/Adapter/Proxy: Forward stderr" forever $ do bs <- readChan dbErr debugMsg (T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs) @@ -92,16 +101,43 @@ else do debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs) writeChan dbIn bs >> loop - in ignoreIOException loop) - - liftIO $ link fwd_thr - sendRunProxyInTerminal port + in ignoreIOException $ do + labelMe "Debug/Adapter/Proxy: Read stdin" + loop) where ignoreIOException a = catch a $ \(e::IOException) -> infoMsg (T.pack $ "Ignoring connection broken to proxy client: " ++ show e) debugMsg msg = l <& WithSeverity msg Debug infoMsg msg = l <& WithSeverity msg Info + +-- | A version of @runTCPServerWithSocket@ that kills the forked connection +-- handlers when killed. +runTCPServerWithSocket' :: Socket -> (Socket -> IO a1) -> IO a2 +runTCPServerWithSocket' sock server = do + let + serverLoop = forever $ E.bracketOnError (accept sock) (close . fst) $ + \(conn, _peer) -> + mask_ $ withAsyncWithUnmask + (\ unmask -> + unmask (labelMe "TCP Server handler" >> server conn) + `finally` gracefulClose conn 5000) + (const serverLoop) + serverLoop + +-- | Label the running thread +labelMe :: String -> IO () +labelMe name = do + tid <- myThreadId + labelThread tid name + +-- | Open a socket on an available port +openSocketAvailablePort :: IO Socket +openSocketAvailablePort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } + addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + -- Bind on "0" to let the OS pick a free port + openTCPServerSocket addr -- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. -- diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb/Development/Debug/Adapter/Stopped.hs --- a/hdb/Development/Debug/Adapter/Stopped.hs +++ b/hdb/Development/Debug/Adapter/Stopped.hs @@ -99,7 +99,7 @@ varId <- freshVarIx six (scopeToVarRef kind) source <- fileToSource sourceSpan.file - return defaultScope + return Scope { scopeName = case kind of LocalVariablesScope -> "Locals" ModuleVariablesScope -> "Module" @@ -109,12 +109,14 @@ ModuleVariablesScope -> ScopePresentationHint "module" GlobalVariablesScope -> ScopePresentationHint "globals" , scopeNamedVariables = numVars + , scopeIndexedVariables = Nothing , scopeSource = Just source , scopeLine = Just sourceSpan.startLine , scopeColumn = Just sourceSpan.startCol , scopeEndLine = Just sourceSpan.endLine , scopeEndColumn = Just sourceSpan.endCol , scopeVariablesReference = varId + , scopeExpensive = expensive } -------------------------------------------------------------------------------- diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -103,10 +103,11 @@ printResponse out Just input -> do mcmd <- parseCmd input - lift $ modify (\ o -> o { runLastCommand = mcmd }) case mcmd of Nothing -> return () - Just cmd -> do + Just Exit -> outputStrLn "Exiting..." >> liftIO (exitWith ExitSuccess) + Just (Do cmd) -> do + lift $ modify (\ o -> o { runLastCommand = Just cmd }) out <- lift . lift $ execute cmd printResponse out loop @@ -274,12 +275,12 @@ <> metavar "N:INT" <> help "Ignore first N:INT times this breakpoint is hit" )) +data OrExit a = Do a + | Exit + deriving Functor + runParser :: RunOptions -> Parser Command runParser opts = - -- --entry with some args - -- (DebugExecution <$> parseEntry <*> parseSomeArgs) - -- --entry without any args - -- <|> (DebugExecution <$> parseEntry <*> pure []) -- just some args (DebugExecution (mkEntry (runEntryPoint opts)) (runEntryFile opts) <$> parseSomeArgs) -- just "run" @@ -301,58 +302,62 @@ | otherwise = FunctionEntry (runEntryPoint opts) -- | Combined parser for 'Command' -cmdParser :: RunOptions -> RunContext -> Parser Command +cmdParser :: RunOptions -> RunContext -> Parser (OrExit Command) cmdParser opts ctx = hsubparser ( Options.Applicative.command "delete" - ( info (DelBreakpoint <$> breakpointParser) + ( info (Do . DelBreakpoint <$> breakpointParser) ( progDesc "Delete a breakpoint" ) ) <> Options.Applicative.command "run" - ( info (runParser opts) + ( info (Do <$> runParser opts) ( progDesc "Run the debuggee" ) ) <> Options.Applicative.command "next" - ( info (pure DoStepLocal) + ( info (pure $ Do DoStepLocal) ( progDesc "Step over to the next line" ) ) <> Options.Applicative.command "step" - ( info (pure DoSingleStep) + ( info (pure $ Do DoSingleStep) ( progDesc "Step-in to the next immediate location" ) ) <> Options.Applicative.command "finish" - ( info (pure DoStepOut) + ( info (pure $ Do DoStepOut) ( progDesc "Step-out of the current function into the caller/its continuation" ) ) <> Options.Applicative.command "continue" - ( info (pure DoContinue) + ( info (pure $ Do DoContinue) ( progDesc "Continue executing from the current breakpoint" ) ) <> Options.Applicative.command "print" - ( info (DoEval . unwords <$> many (argument str ( metavar "EXPRESSION" + ( info (Do . DoEval . unwords <$> many (argument str ( metavar "EXPRESSION" <> help "Expression to evaluate in the current context" ))) ( progDesc "Evaluate an expression in the current context" ) ) <> Options.Applicative.command "exit" - ( info (pure TerminateProcess) + ( info (pure Exit) ( progDesc "Terminate and exit the debugger session" ) ) <> Options.Applicative.command "threads" - ( info (pure GetThreads) + ( info (pure $ Do GetThreads) ( progDesc "Print all user threads" ) ) <> Options.Applicative.command "backtrace" - ( info (stackTraceParser ctx <**> helper) + ( info (Do <$> stackTraceParser ctx <**> helper) ( progDesc "Print stack trace" ) ) <> Options.Applicative.command "variables" - ( info (variablesParser ctx <**> helper) + ( info (Do <$> variablesParser ctx <**> helper) ( progDesc "Print local variables" ) ) <> Options.Applicative.command "break" - ( info (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser) + ( info (Do <$> (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser <*> logMessageParser)) ( progDesc "Set a breakpoint" ) ) ) +-- | TODO: handle this as part of issue #144 +logMessageParser :: Parser (Maybe String) +logMessageParser = pure Nothing + stackTraceParser :: RunContext -> Parser Command stackTraceParser ctx = GetStacktrace <$> threadIdParser ctx "Print backtrace of THREAD_ID. Defaults to current thread at breakpoint." @@ -370,12 +375,12 @@ <|> Maybe.maybe (empty <**> abortOption (ErrorMsg "Not stopped at a Breakpoint") mempty) pure (runCurrentThread ctx) -- | Main parser info -cmdParserInfo :: RunOptions -> RunContext -> ParserInfo Command +cmdParserInfo :: RunOptions -> RunContext -> ParserInfo (OrExit Command) cmdParserInfo opts ctx = info (cmdParser opts ctx) ( fullDesc ) -- | Parse command line arguments -parseCmd :: String -> InteractiveDM (Maybe Command) +parseCmd :: String -> InteractiveDM (Maybe (OrExit Command)) parseCmd input = do opts <- lift ask ctx <- lift get @@ -385,8 +390,8 @@ (cmdParserInfo opts ctx) (words input) in case res of - Success x -> - return (Just x) + Success cmd -> + return (Just cmd) Failure bad -> let (msg, _exit) = renderFailure bad "(hdb)" in outputStrLn msg >> pure Nothing diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs --- a/hdb/Development/Debug/Options.hs +++ b/hdb/Development/Debug/Options.hs @@ -30,15 +30,20 @@ -- | @proxy --port @ -- -- The proxy command serves as a middle man between the user and the debugger. - -- It is used implicitly by DAP mode: upon initialization, the debugger - -- server asks the DAP client to @runInTerminal@ the @hdb proxy --port ...@ - -- command at a port determined by the debugger server. + -- It is used implicitly by DAP mode when using the internal interpreter: + -- upon initialization, the debugger server asks the DAP client to + -- @runInTerminal@ the @hdb proxy --port ...@ command at a port determined by + -- the debugger server. -- -- The proxy mode will forward stdin to the debugger server and will be -- forwarded the debuggee's stdout. This essentially enables the user to -- observe and interact with the execution of the debugger, in a standalone -- terminal. -- + -- (When using the external interpreter, the proxy isn't necessary because + -- the DAP server can launch directly the external interpreter attached to + -- the user's terminal) + -- -- See #44 for the original ticket | HdbProxy { port :: Int @@ -65,3 +70,8 @@ , readFd :: Int } + -- | Launch the custom-for-the-debugger external interpreter and connect it + -- to the debugger through a TCP socket. + | HdbExternalInterpreterPort + { port :: Int + } diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs --- a/hdb/Development/Debug/Options/Parser.hs +++ b/hdb/Development/Debug/Options/Parser.hs @@ -89,16 +89,24 @@ <> help "proxy port to which the debugger connects" ) <*> verbosityParser Warning --- | Parser for @hdb external-interpreter @ +-- | Parser for @hdb external-interpreter @ or +-- @hdb external-interpreter --port @ -- See Note [Custom external interpreter] extInterpParser :: Parser HdbOptions -extInterpParser = HdbExternalInterpreter - <$> argument auto - ( metavar "WRITE_FD" - <> help "external interpreter write file descriptor" ) - <*> argument auto - ( metavar "READ_FD" - <> help "external interpreter read file descriptor" ) +extInterpParser = + HdbExternalInterpreterPort + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "port on which the external interpreter should connect to the debugger" ) + <|> HdbExternalInterpreter + <$> argument auto + ( metavar "WRITE_FD" + <> help "external interpreter write file descriptor" ) + <*> argument auto + ( metavar "READ_FD" + <> help "external interpreter read file descriptor" ) -- | Combined parser for HdbOptions hdbOptionsParser :: Parser HdbOptions @@ -111,7 +119,7 @@ ( progDesc "Debug a Haskell program in CLI mode" ) ) <> Options.Applicative.command "proxy" ( info proxyParser - ( progDesc "Internal mode used by the DAP server to proxy the stdin/stdout to the DAP client's terminal" ) ) + ( progDesc "Internal mode used by the DAP server to proxy stdin/stdout to the DAP client's terminal when using the internal interpreter" ) ) <> Options.Applicative.command "external-interpreter" ( info extInterpParser ( progDesc "Start the custom-for-debugger external interpreter" ) ) diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs --- a/hdb/Development/Debug/Session/Setup.hs +++ b/hdb/Development/Debug/Session/Setup.hs @@ -15,6 +15,7 @@ ) where import Control.Applicative ((<|>)) +import Control.Concurrent (newMVar, MVar, withMVar) import Control.Exception (handleJust) import Control.Monad import Control.Monad.Except @@ -26,11 +27,13 @@ import Data.Maybe import Data.Version import Data.Void -import System.Directory hiding (findFile) +import System.Directory hiding (withCurrentDirectory, findFile) +import System.Directory qualified as D import System.FilePath import System.IO.Error import Text.ParserCombinators.ReadP (readP_to_S) import Data.Functor.Contravariant +import GHC.IO (unsafePerformIO) import qualified Data.Text as T @@ -345,3 +348,10 @@ forgetPatchVersion v = case versionBranch v of (major:minor:_patches) -> makeVersion [major, minor] _ -> v + +{-# NOINLINE cwdLock #-} +cwdLock :: MVar () +cwdLock = unsafePerformIO $ newMVar () + +withCurrentDirectory :: FilePath -> IO b -> IO b +withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -11,8 +11,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Except -import Control.Exception (uninterruptibleMask) +import Control.Exception (bracket, uninterruptibleMask, bracketOnError) import Control.Exception.Backtrace import DAP @@ -24,17 +23,28 @@ import Development.Debug.Adapter.Evaluation import Development.Debug.Adapter.ExceptionInfo import Development.Debug.Adapter.Exit +import Development.Debug.Adapter.Exit.Helpers import Development.Debug.Adapter.Handles import Colog.Core import Data.Time -import System.IO (hSetBuffering, BufferMode(LineBuffering), Handle, openFile, IOMode(ReadMode)) +import System.IO + ( hFlush + , hClose + , hPutStrLn + , hSetBuffering + , BufferMode(..) + , Handle + , openFile + , IOMode(ReadMode, ReadWriteMode) + ) import qualified DAP.Log as DAP import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD import Data.Functor.Contravariant +import Network.Socket hiding (Debug) import qualified GHCi.Server as GHCi import qualified GHCi.Signals as GHCi @@ -48,7 +58,12 @@ import Development.Debug.Adapter import Development.Debug.Adapter.Proxy import Development.Debug.Interactive +import GHC.Stack.Annotation (annotateCallStackIO) +#if MIN_VERSION_ghc(9,15,0) +import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler) +#endif + -------------------------------------------------------------------------------- main :: IO () @@ -72,11 +87,9 @@ hSetBuffering realStdout LineBuffering l <- mainLogger hdbOpts.verbosity realStdout init_var <- liftIO (newIORef False{-not supported by default-}) - pid_var <- liftIO (newIORef Nothing) - ccon_var <- liftIO newEmptyMVar runDAPServerWithLogger (contramap DAPLibraryLog l) config - (talk l init_var pid_var ccon_var internalInterpreter) - (ack l pid_var) + (talk l init_var internalInterpreter) + (ack l ) HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) l <- mainLogger hdbOpts.verbosity stdout @@ -87,7 +100,7 @@ { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False , preferInternalInterpreter = internalInterpreter - , externalInterpreterStdinStream = stdinStream + , externalInterpreterCustomProc = Left stdinStream } runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs runConf debugInteractive @@ -98,14 +111,49 @@ HdbExternalInterpreter{writeFd, readFd} -> do inh <- GHCi.readGhcHandle (show readFd) outh <- GHCi.readGhcHandle (show writeFd) + runExternalInterpreterServer inh outh + HdbExternalInterpreterPort{port} -> do + pid <- getCurrentPid + withExternalInterpreterPort (fromIntegral port) $ \h -> do + hPutStrLn h (show pid) + hFlush h + runExternalInterpreterServer h h + where + runExternalInterpreterServer inh outh = do GHCi.installSignalHandlers pipe <- GHCi.mkPipeFromHandles inh outh let verbose = False +#if MIN_VERSION_ghc(9,15,0) + uninterruptibleMask $ \restore -> + GHCi.servWithCustom verbose hook pipe restore dbgInterpCmdHandler +#else uninterruptibleMask $ GHCi.serv verbose hook pipe +#endif where hook = return -- empty hook -- we cannot allow any async exceptions while communicating, because -- we will lose sync in the protocol, hence uninterruptibleMask. - where + + withExternalInterpreterPort :: PortNumber -> (Handle -> IO a) -> IO a + withExternalInterpreterPort port k = do + bracket (mkHandleFromPortSock "127.0.0.1" port) hClose $ \ h -> do + annotateCallStackIO $ k h + + mkHandleFromPortSock :: HostName -> PortNumber -> IO Handle + mkHandleFromPortSock host port = do + let hints = defaultHints { addrSocketType = Stream } + addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port)) + + Control.Exception.bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + close + (\sock -> do + -- Don't delay, avoids batching + setSocketOption sock NoDelay 1 + connect sock (addrAddress addr) + h <- socketToHandle sock ReadWriteMode + hSetBuffering h NoBuffering + return h) + -- When using the internal interpreter in DAP mode, we can't write to -- stdout directly because there will also be a thread forwarding the -- debuggee stdout by capturing it from stdout (and we'd get into a loop @@ -165,14 +213,14 @@ , supportsExceptionOptions = True , supportsValueFormattingOptions = True , supportsExceptionInfoRequest = True - , supportTerminateDebuggee = True + , supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee , supportSuspendDebuggee = False , supportsDelayedStackTraceLoading = False , supportsLoadedSourcesRequest = False - , supportsLogPoints = False + , supportsLogPoints = True , supportsTerminateThreadsRequest = False , supportsSetExpression = False - , supportsTerminateRequest = False + , supportsTerminateRequest = True , supportsDataBreakpoints = False , supportsReadMemoryRequest = False , supportsWriteMemoryRequest = False @@ -203,16 +251,11 @@ talk :: LogAction IO MainLog -> IORef Bool -- ^ Whether the client supports runInTerminal - -> IORef (Maybe Int) - -- ^ The PID of the runInTerminal proxy process - -> MVar () - -- ^ A var to block on waiting for the proxy client to connect, if a proxy - -- connection is expected. See #95. -> Bool -- ^ Prefer internal interpreter -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l support_rit_var _pid_var client_proxy_signal prefer_internal_interpreter = \ case +talk l support_rit_var prefer_internal_interpreter = \ case CommandInitialize -> do InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments #ifdef mingw32_HOST_OS @@ -222,43 +265,36 @@ #else let runInTerminal = fromMaybe False supportsRunInTerminalRequest #endif + -- This global variable is wrong. Even though we only register the session + -- and the per-session state on Launch (which gives us __sessionId), the + -- *initialize* command is run once per new session on a new connection and + -- two different clients which may differ in their support for + -- 'runInTerminal'. + -- + -- The `dap` library should likely keep track of the client capabilities + -- per connection. liftIO $ writeIORef support_rit_var runInTerminal sendInitializeResponse - - -- If runInTerminal is not supported by the client, signal readiness right away - when (not runInTerminal) $ - liftIO $ putMVar client_proxy_signal () -------------------------------------------------------------------------------- CommandLaunch -> do launch_args <- getArguments + -- Wrong-ish. See above where this variable is written supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var - merror <- runExceptT $ - initDebugger (contramap DAPLog l) - supportsRunInTerminalRequest prefer_internal_interpreter - launch_args - case merror of - Right () -> do - sendLaunchResponse -- ack - sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session - - -- Run the proxy in a separate terminal to accept stdin / forward stdout - -- if it is supported - when supportsRunInTerminalRequest $ do - -- Run proxy thread, server side, and - -- send the 'runInTerminal' request - serverSideHdbProxy (contramap RunProxyServerLog l) client_proxy_signal + initDebugger (contramap DAPLog l) + supportsRunInTerminalRequest prefer_internal_interpreter + launch_args - liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info) + sendLaunchResponse -- ack + sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session - Left (InitFailed err) -> do - sendErrorResponse (ErrorMessage (T.pack err)) Nothing - exitCleanly Nothing + liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info) -------------------------------------------------------------------------------- CommandAttach -> do - sendErrorResponse (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing - exitCleanly Nothing + sendTerminatedEvent (TerminatedEvent False) + destroyDebugSession + sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing -------------------------------------------------------------------------------- CommandBreakpointLocations -> commandBreakpointLocations CommandSetBreakpoints -> commandSetBreakpoints @@ -272,10 +308,16 @@ ---------------------------------------------------------------------------- CommandConfigurationDone -> do sendConfigurationDoneResponse - -- now that it has been configured, start executing until it halts, then send an event - -- wait for the proxy client to connect before starting the execution (#95) - () <- liftIO $ takeMVar client_proxy_signal + DAS{runInTerminalProc} <- getDebugSession + case runInTerminalProc of + RunProxyInTerminal{proxyClientReady} -> liftIO $ do + -- Only start executing after proxy client connects succesfully (#95) + takeMVar proxyClientReady + _ -> + pure () + + -- Configuration is finished. Start executing until it halts. startExecution >>= handleEvalResult False ---------------------------------------------------------------------------- CommandThreads -> commandThreads @@ -292,32 +334,36 @@ ---------------------------------------------------------------------------- CommandEvaluate -> commandEvaluate ---------------------------------------------------------------------------- - CommandTerminate -> do - commandTerminate + CommandTerminate -> commandTerminate CommandDisconnect -> commandDisconnect ---------------------------------------------------------------------------- CommandModules -> sendModulesResponse (ModulesResponse [] Nothing) CommandSource -> undefined CommandPause -> pure () -- TODO (CustomCommand "mycustomcommand") -> undefined - (CustomCommand "runInTerminal") -> do - -- Ignore result of runInTerminal (reverse request) response. - -- If it fails, we simply continue without that functionality. - pure () other -> do - sendErrorResponse (ErrorMessage (T.pack ("Unsupported command: " <> show other))) Nothing - exitCleanly Nothing ----------------------------------------------------------------------------- --- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ----------------------------------------------------------------------------- + terminateWithError ("Unsupported command: " <> show other) -- | Receive reverse request responses (such as runInTerminal response) ack :: LogAction IO MainLog - -> IORef (Maybe Int) - -- ^ Reference to PID of runInTerminal proxy process running -> ReverseRequestResponse -> DebugAdaptorCont () -ack l _ref rrr = case rrr.reverseRequestCommand of +ack l rrr = case rrr.reverseRequestCommand of ReverseCommandRunInTerminal -> do + + RunInTerminalResponse{} <- getReverseRequestResponseBody rrr + + -- TODO: keep track of body.shellProcessId to then kill the proxy when the + -- session is terminated: + -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED] + -- { + -- "body": { + -- "shellProcessId": 2092 + -- }, + -- "command": "runInTerminal", + -- "seq": 14, + -- "success": true, + -- "type": "response" + -- } when rrr.success $ do liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info) _ -> pure () @@ -329,7 +375,6 @@ data MainLog = DAPLog DAPLog | InteractiveLog InteractiveLog - | RunProxyServerLog (WithSeverity T.Text) | RunProxyClientLog (WithSeverity T.Text) | DAPLaunchLog (WithSeverity T.Text) | DAPLibraryLog DAP.DAPLog @@ -368,9 +413,9 @@ pure $ LogAction $ \case DAPLog (DAPSessionSetupLog sessionLog) -> logSessionLog sessionLog DAPLog (DAPDebuggerLog debuggerLog) -> logDebuggerLog debuggerLog + DAPLog (RunProxyServerLog sev_msg) -> defaultLog sev_msg InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog sessionLog InteractiveLog (IDebuggerLog debuggerLog) -> logDebuggerLog debuggerLog - RunProxyServerLog sev_msg -> defaultLog sev_msg RunProxyClientLog sev_msg -> defaultLog sev_msg DAPLaunchLog sev_msg -> defaultLog sev_msg DAPLibraryLog t -> diff --git a/test/golden/T130/T130.cabal b/test/golden/T130/T130.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.14 +name: T130 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Lib + build-depends: base, haskell-debugger-view == 0.1.0.0 + hs-source-dirs: lib + default-language: Haskell2010 + +executable T130 + import: warnings + main-is: Main.hs + build-depends: base, T130 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/golden/T130/T130.ghc-914.hdb-stdout b/test/golden/T130/T130.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.ghc-914.hdb-stdout @@ -0,0 +1,2 @@ +Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) +While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.ghc-915.hdb-stdout b/test/golden/T130/T130.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130/T130.ghc-915.hdb-stdout @@ -0,0 +1,2 @@ +Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) +While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.hdb-stdout b/test/golden/T130/T130.hdb-stdout deleted file mode 100644 --- a/test/golden/T130/T130.hdb-stdout +++ /dev/null @@ -1,1 +0,0 @@ -Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130b/T130b.cabal b/test/golden/T130b/T130b.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.14 +name: T130b +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Lib + build-depends: base, haskell-debugger-view == 0.2.0.0 + hs-source-dirs: lib + default-language: Haskell2010 + +executable T130b + import: warnings + main-is: Main.hs + build-depends: base, T130b + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/golden/T130b/T130b.ghc-914.hdb-stdout b/test/golden/T130b/T130b.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.ghc-914.hdb-stdout @@ -0,0 +1,4 @@ +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b] +(hdb) MyType +() +(hdb) Exiting... diff --git a/test/golden/T130b/T130b.ghc-915.hdb-stdout b/test/golden/T130b/T130b.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130b/T130b.ghc-915.hdb-stdout @@ -0,0 +1,4 @@ +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b] +(hdb) MyType +() +(hdb) Exiting... diff --git a/test/golden/T130b/T130b.hdb-stdout b/test/golden/T130b/T130b.hdb-stdout deleted file mode 100644 --- a/test/golden/T130b/T130b.hdb-stdout +++ /dev/null @@ -1,4 +0,0 @@ -[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T130b-0.1.0.0-inplace-T130b] -(hdb) MyType -() -(hdb) Exiting... diff --git a/test/golden/T130c/T130c.cabal b/test/golden/T130c/T130c.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T130c/T130c.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: T130c +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Lib + build-depends: base, haskell-debugger-view + hs-source-dirs: lib + default-language: Haskell2010 + diff --git a/test/golden/T130c/T130c.ghc-914.hdb-stdout b/test/golden/T130c/T130c.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T130c/T130c.ghc-914.hdb-stdout @@ -0,0 +1,7 @@ +[1 of 1] Compiling Lib ( /lib/Lib.hs, interpreted )[T130c-0.1.0.0-inplace] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +value : ColonList = _ + value : ColonList = alpha:beta:gamma +(hdb) Exiting... diff --git a/test/golden/T130c/T130c.hdb-stdin b/test/golden/T130c/T130c.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T130c/T130c.hdb-stdin @@ -0,0 +1,3 @@ +break lib/Lib.hs 16 +run +variables diff --git a/test/golden/T130c/T130c.hdb-test b/test/golden/T130c/T130c.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T130c/T130c.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T130c.hdb-stdin diff --git a/test/golden/T130c/lib/Lib.hs b/test/golden/T130c/lib/Lib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T130c/lib/Lib.hs @@ -0,0 +1,19 @@ +module Lib (mainish) where + +import Data.List (intercalate) +import GHC.Debugger.View.Class + +data ColonList = ColonList [String] + deriving Show + +instance DebugView ColonList where + debugValue (ColonList xs) = simpleValue (intercalate ":" xs) False + debugFields _ = pure (VarFields []) + +mainish :: IO () +mainish = do + let value = mkValue + print value + +mkValue :: ColonList +mkValue = ColonList ["alpha", "beta", "gamma"] diff --git a/test/golden/T135/T135.ghc-914.hdb-stdout b/test/golden/T135/T135.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T135/T135.ghc-914.hdb-stdout @@ -0,0 +1,13 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] +/myapp/app/Main.hs:3:1: warning: [GHC-66111] [-Wunused-imports] + The import of ‘MyLib’ is redundant + except perhaps to import instances from ‘MyLib’ + To import instances alone, use: import MyLib() + | +3 | import MyLib (someFunc) + | ^^^^^^^^^^^^^^^^^^^^^^^ + +(hdb) Hello, Haskell! +() +(hdb) Exiting... diff --git a/test/golden/T135/T135.ghc-915.hdb-stdout b/test/golden/T135/T135.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T135/T135.ghc-915.hdb-stdout @@ -0,0 +1,13 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /myapp/app/Main.hs, /.hdb-cache//Main.gbc )[myapp-0.1.0.0-inplace-myapp] +/myapp/app/Main.hs:3:1: warning: [GHC-66111] [-Wunused-imports] + The import of ‘MyLib’ is redundant + except perhaps to import instances from ‘MyLib’ + To import instances alone, use: import MyLib() + | +3 | import MyLib (someFunc) + | ^^^^^^^^^^^^^^^^^^^^^^^ + +(hdb) Hello, Haskell! +() +(hdb) Exiting... diff --git a/test/golden/T135/T135.hdb-stdout b/test/golden/T135/T135.hdb-stdout deleted file mode 100644 --- a/test/golden/T135/T135.hdb-stdout +++ /dev/null @@ -1,13 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] -/myapp/app/Main.hs:3:1: warning: [GHC-66111] [-Wunused-imports] - The import of ‘MyLib’ is redundant - except perhaps to import instances from ‘MyLib’ - To import instances alone, use: import MyLib() - | -3 | import MyLib (someFunc) - | ^^^^^^^^^^^^^^^^^^^^^^^ - -(hdb) Hello, Haskell! -() -(hdb) Exiting... diff --git a/test/golden/T135/cabal.project b/test/golden/T135/cabal.project new file mode 100644 --- /dev/null +++ b/test/golden/T135/cabal.project @@ -0,0 +1,1 @@ +packages: mylib myapp diff --git a/test/golden/T135/hie.yaml b/test/golden/T135/hie.yaml new file mode 100644 --- /dev/null +++ b/test/golden/T135/hie.yaml @@ -0,0 +1,6 @@ +cradle: + cabal: + - path: "./mylib" + component: "lib:mylib" + - path: "./myapp/" + component: "myapp" diff --git a/test/golden/T135/myapp/myapp.cabal b/test/golden/T135/myapp/myapp.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T135/myapp/myapp.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: myapp +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable myapp + import: warnings + main-is: Main.hs + build-depends: base, mylib >= 0.1234 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/golden/T135/mylib/mylib.cabal b/test/golden/T135/mylib/mylib.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T135/mylib/mylib.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: mylib +version: 0.1234.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/golden/T154/T154.ghc-914.hdb-stdout b/test/golden/T154/T154.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T154/T154.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T154/T154.ghc-915.hdb-stdout b/test/golden/T154/T154.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T154/T154.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T154/T154.hdb-stdout b/test/golden/T154/T154.hdb-stdout deleted file mode 100644 --- a/test/golden/T154/T154.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] -(hdb) hello -() -(hdb) Exiting... diff --git a/test/golden/T159/T159.ghc-914.hdb-stdout b/test/golden/T159/T159.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.ghc-914.hdb-stdout @@ -0,0 +1,6 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T159.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} +(hdb) Stopped at breakpoint +(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at /T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}] +(hdb) Exiting... diff --git a/test/golden/T159/T159.ghc-915.hdb-stdout b/test/golden/T159/T159.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T159/T159.ghc-915.hdb-stdout @@ -0,0 +1,6 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T159.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} +(hdb) Stopped at breakpoint +(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation, called at /T159.hs:7:7 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4], called at /T159.hs:6:5 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at /T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}] +(hdb) Exiting... diff --git a/test/golden/T159/T159.hdb-stdout b/test/golden/T159/T159.hdb-stdout deleted file mode 100644 --- a/test/golden/T159/T159.hdb-stdout +++ /dev/null @@ -1,6 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T159.hs, interpreted )[main] -(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} -(hdb) Stopped at breakpoint -(hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at /T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}] -(hdb) Exiting... diff --git a/test/golden/T159/hie.yaml b/test/golden/T159/hie.yaml new file mode 100644 --- /dev/null +++ b/test/golden/T159/hie.yaml @@ -0,0 +1,8 @@ +cradle: + direct: + arguments: + - -i + - -i. + - T159.hs + - -package base + - -package ghc-experimental diff --git a/test/golden/T164/T164.ghc-914.hdb-stdout b/test/golden/T164/T164.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T164/T164.ghc-914.hdb-stdout @@ -0,0 +1,25 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +existentialFoo : Foo = Foo + _1 : r0 = _ + _2 : [Char] = "value" +existentialFoo2 : Foo2 = Foo2 + _1 : r0 = _ + foo : [Char] = "value2" +foo3 : Foo3 = Foo3 + _1 : Int = 0 + _2 : Word = 1 + _3 : Int = 2 + _4 : Int = 3 +foo4 : Foo4 = Foo4 + _1 : Word32 = 0 + _2 : Word16 = 1 + _3 : Word64 = 2 + _4 : Word16 = 3 +foo5 : Foo5 = Foo5 + _1 : ?impl::String = _ + _2 : String = _ +(hdb) Exiting... diff --git a/test/golden/T164/T164.ghc-915.hdb-stdout b/test/golden/T164/T164.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T164/T164.ghc-915.hdb-stdout @@ -0,0 +1,27 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = _ +*** Ignoring breakpoint [/Main.hs:42:3-69] + _result : IO () = _ +existentialFoo : Foo = Foo + _1 : r0 = _ + _2 : [Char] = "value" +existentialFoo2 : Foo2 = Foo2 + _1 : r0 = _ + foo : [Char] = "value2" +foo3 : Foo3 = Foo3 + _1 : Int = 0 + _2 : Word = 1 + _3 : Int = 2 + _4 : Int = 3 +foo4 : Foo4 = Foo4 + _1 : Word32 = 0 + _2 : Word16 = 1 + _3 : Word64 = 2 + _4 : Word16 = 3 +foo5 : Foo5 = Foo5 + _1 : ?impl::String = _ + _2 : String = _ +(hdb) diff --git a/test/golden/T164/T164.hdb-stdout b/test/golden/T164/T164.hdb-stdout deleted file mode 100644 --- a/test/golden/T164/T164.hdb-stdout +++ /dev/null @@ -1,27 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] -(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} -(hdb) Stopped at breakpoint -(hdb) _result : IO () = _ -*** Ignoring breakpoint [/Main.hs:42:3-69] - _result : IO () = _ -existentialFoo : Foo = Foo - _1 : r0 = _ - _2 : [Char] = "value" -existentialFoo2 : Foo2 = Foo2 - _1 : r0 = _ - foo : [Char] = "value2" -foo3 : Foo3 = Foo3 - _1 : Int = 0 - _2 : Word = 1 - _3 : Int = 2 - _4 : Int = 3 -foo4 : Foo4 = Foo4 - _1 : Word32 = 0 - _2 : Word16 = 1 - _3 : Word64 = 2 - _4 : Word16 = 3 -foo5 : Foo5 = Foo5 - _1 : ?impl::String = _ - _2 : String = _ -(hdb) diff --git a/test/golden/T166/Main.hs b/test/golden/T166/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T166/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/test/golden/T166/T166.ghc-914.hdb-stdout b/test/golden/T166/T166.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T166/T166.ghc-914.hdb-stdout @@ -0,0 +1,17 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) 1 +(hdb) 1 +(hdb) Prelude.undefined + +HasCallStack backtrace: + undefined, called at :1:1 in interactive:Ghci4 + +(hdb) Prelude.undefined + +HasCallStack backtrace: + undefined, called at :1:1 in interactive:Ghci4 + +(hdb) _ +(hdb) [...] +(hdb) Exiting... diff --git a/test/golden/T166/T166.hdb-stdin b/test/golden/T166/T166.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T166/T166.hdb-stdin @@ -0,0 +1,6 @@ +print 1 +print let x = 1 +print undefined +print undefined :: Int +print x <- readFile "Main.hs" +print let a = [1]; b = [2,3] diff --git a/test/golden/T166/T166.hdb-stdout b/test/golden/T166/T166.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T166/T166.hdb-stdout @@ -0,0 +1,17 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) 1 +(hdb) 1 +(hdb) Prelude.undefined + +HasCallStack backtrace: + undefined, called at :1:1 in interactive:Ghci4 + +(hdb) Prelude.undefined + +HasCallStack backtrace: + undefined, called at :1:1 in interactive:Ghci4 + +(hdb) _ +(hdb) [...] +(hdb) Exiting... diff --git a/test/golden/T166/T166.hdb-test b/test/golden/T166/T166.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T166/T166.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T166.hdb-stdin diff --git a/test/golden/T169/T169.ghc-914.hdb-stdout b/test/golden/T169/T169.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T169/T169.ghc-915.hdb-stdout b/test/golden/T169/T169.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) hello +() +(hdb) Exiting... diff --git a/test/golden/T169/T169.hdb-stdout b/test/golden/T169/T169.hdb-stdout deleted file mode 100644 --- a/test/golden/T169/T169.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] -(hdb) hello -() -(hdb) Exiting... diff --git a/test/golden/T169/T169b.ghc-914.hdb-stdout b/test/golden/T169/T169b.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.ghc-914.hdb-stdout @@ -0,0 +1,10 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169b.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} +(hdb) Stopped at breakpoint +(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] +(hdb) Debuggee writing something to stdout +[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] +(hdb) Debuggee writing something to stderr +() +(hdb) Exiting... diff --git a/test/golden/T169/T169b.ghc-915.hdb-stdout b/test/golden/T169/T169b.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169b.ghc-915.hdb-stdout @@ -0,0 +1,10 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169b.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} +(hdb) Stopped at breakpoint +(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 354, expensive = True}] +(hdb) Debuggee writing something to stdout +[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 354, expensive = True}] +(hdb) Debuggee writing something to stderr +() +(hdb) Exiting... diff --git a/test/golden/T169/T169b.hdb-stdout b/test/golden/T169/T169b.hdb-stdout deleted file mode 100644 --- a/test/golden/T169/T169b.hdb-stdout +++ /dev/null @@ -1,10 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169b.hs, interpreted )[main] -(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} -(hdb) Stopped at breakpoint -(hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] -(hdb) Debuggee writing something to stdout -[ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 8, endLine = 8, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] -(hdb) Debuggee writing something to stderr -() -(hdb) Exiting... diff --git a/test/golden/T169/T169c.external.ghc-914.hdb-stdout b/test/golden/T169/T169c.external.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.external.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] +(hdb) "hello there" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.external.ghc-915.hdb-stdout b/test/golden/T169/T169c.external.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.external.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169c.hs, /.hdb-cache//Main.gbc )[main] +(hdb) "hello there" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.external.hdb-stdout b/test/golden/T169/T169c.external.hdb-stdout deleted file mode 100644 --- a/test/golden/T169/T169c.external.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] -(hdb) "hello there" -() -(hdb) Exiting... diff --git a/test/golden/T169/T169c.internal.ghc-914.hdb-stdout b/test/golden/T169/T169c.internal.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.internal.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] +(hdb) "hello world" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.internal.ghc-915.hdb-stdout b/test/golden/T169/T169c.internal.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T169/T169c.internal.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /T169c.hs, /.hdb-cache//Main.gbc )[main] +(hdb) "hello world" +() +(hdb) Exiting... diff --git a/test/golden/T169/T169c.internal.hdb-stdout b/test/golden/T169/T169c.internal.hdb-stdout deleted file mode 100644 --- a/test/golden/T169/T169c.internal.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] -(hdb) "hello world" -() -(hdb) Exiting... diff --git a/test/golden/T217/Main.hs b/test/golden/T217/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T217/Main.hs @@ -0,0 +1,20 @@ +newtype D a = D {unD :: D a -> a} +newtype B = B (Either String Bool) + deriving Show +{-# OPAQUE f #-} +f :: B -> Either B B +f b = Left b + +main = do + let doit = const (pure () :: IO ()) + let y = D (const $ 'y') + let x :: (a ~ IO ()) => a + x = print () + -- to preserve newtype constructor `B` in reconstructed Term we must not force `ix` + -- until after the breakpoint. + ix <- pure $ B (Left "A") + putStrLn "helio" + doit () + print $ unD y y + x + print (f ix) diff --git a/test/golden/T217/T217.ghc-914.hdb-stdout b/test/golden/T217/T217.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T217/T217.ghc-914.hdb-stdout @@ -0,0 +1,12 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 13], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 17, endLine = 17, startCol = 3, endCol = 10}} +(hdb) helio +Stopped at breakpoint +(hdb) _result : IO () = :: IO () +x : forall a. (a ~ IO ()) => a = :: forall a. (a ~ IO ()) => a +y : D Char -> Char = :: D Char -> Char +doit : forall {b}. b -> IO () = :: forall {b}. b -> IO () +ix : B = _ + ix : B = B (Left _) +(hdb) Exiting... diff --git a/test/golden/T217/T217.hdb-stdin b/test/golden/T217/T217.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T217/T217.hdb-stdin @@ -0,0 +1,3 @@ +break Main.hs 17 +run +variables diff --git a/test/golden/T217/T217.hdb-test b/test/golden/T217/T217.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T217/T217.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T217.hdb-stdin diff --git a/test/golden/T218/Main.hs b/test/golden/T218/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T218/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/test/golden/T218/T218.ghc-914.hdb-stdout b/test/golden/T218/T218.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T218/T218.ghc-914.hdb-stdout @@ -0,0 +1,12 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) Aborted: :1:1: error: [GHC-88464] + Variable not in scope: isLetter +(hdb) +(hdb) :: Char -> Bool +(hdb) True +(hdb) False +(hdb) Aborted: :1:1: error: [GHC-87110] + Could not find module `Does.Not.Exist'. + Use -v to see a list of the files searched for. +(hdb) Exiting... diff --git a/test/golden/T218/T218.hdb-stdin b/test/golden/T218/T218.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T218/T218.hdb-stdin @@ -0,0 +1,6 @@ +print isLetter +print import Data.Char +print isLetter +print isLetter 'a' +print isLetter '1' +print import Does.Not.Exist diff --git a/test/golden/T218/T218.hdb-stdout b/test/golden/T218/T218.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T218/T218.hdb-stdout @@ -0,0 +1,12 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) Aborted: :1:1: error: [GHC-88464] + Variable not in scope: isLetter +(hdb) +(hdb) :: Char -> Bool +(hdb) True +(hdb) False +(hdb) Aborted: :1:1: error: [GHC-87110] + Could not find module `Does.Not.Exist'. + Use -v to see a list of the files searched for. +(hdb) Exiting... diff --git a/test/golden/T218/T218.hdb-test b/test/golden/T218/T218.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T218/T218.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T218.hdb-stdin diff --git a/test/golden/T225/Main.hs b/test/golden/T225/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T225/Main.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedLists, GeneralizedNewtypeDeriving, DerivingStrategies, UndecidableInstances #-} +module Main where + +import GHC.IsList + +newtype List a = List [a] + deriving Show + deriving newtype IsList + +main = do + return () + return () diff --git a/test/golden/T225/T225.ghc-914.hdb-stdout b/test/golden/T225/T225.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T225/T225.ghc-914.hdb-stdout @@ -0,0 +1,6 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}} +(hdb) Stopped at breakpoint +(hdb) "List [1]" +(hdb) Exiting... diff --git a/test/golden/T225/T225.hdb-stdin b/test/golden/T225/T225.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T225/T225.hdb-stdin @@ -0,0 +1,3 @@ +break Main.hs 11 +run +print show ([1] :: List Int) diff --git a/test/golden/T225/T225.hdb-stdout b/test/golden/T225/T225.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T225/T225.hdb-stdout @@ -0,0 +1,6 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}} +(hdb) Stopped at breakpoint +(hdb) "List [1]" +(hdb) Exiting... diff --git a/test/golden/T225/T225.hdb-test b/test/golden/T225/T225.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T225/T225.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T225.hdb-stdin diff --git a/test/golden/T225b/B.hs b/test/golden/T225b/B.hs new file mode 100644 --- /dev/null +++ b/test/golden/T225b/B.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedLists #-} +module B where + +import Data.Set qualified as Set + +ex :: Set.Set Int +ex = [1,2,3] + +f = do + print 1 + got <- return ex + print got + pure () diff --git a/test/golden/T225b/Main.hs b/test/golden/T225b/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T225b/Main.hs @@ -0,0 +1,8 @@ +module A where + +import B + + +main = do + B.f + return () diff --git a/test/golden/T225b/T225b.ghc-914.hdb-stdout b/test/golden/T225b/T225b.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T225b/T225b.ghc-914.hdb-stdout @@ -0,0 +1,9 @@ +[1 of 4] Compiling B ( /B.hs, interpreted )[main] +[2 of 4] Compiling A ( /Main.hs, interpreted )[main] +[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}} +(hdb) 1 +Stopped at breakpoint +(hdb) "fromList [1,2,3]" +(hdb) Exiting... diff --git a/test/golden/T225b/T225b.hdb-stdin b/test/golden/T225b/T225b.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T225b/T225b.hdb-stdin @@ -0,0 +1,3 @@ +break B.hs 11 +run +print (show ([1,2,3] :: Set.Set Int)) diff --git a/test/golden/T225b/T225b.hdb-stdout b/test/golden/T225b/T225b.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T225b/T225b.hdb-stdout @@ -0,0 +1,9 @@ +[1 of 4] Compiling B ( /B.hs, interpreted )[main] +[2 of 4] Compiling A ( /Main.hs, interpreted )[main] +[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}} +(hdb) 1 +Stopped at breakpoint +(hdb) "fromList [1,2,3]" +(hdb) Exiting... diff --git a/test/golden/T225b/T225b.hdb-test b/test/golden/T225b/T225b.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T225b/T225b.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T225b.hdb-stdin diff --git a/test/golden/T234/T234.cabal b/test/golden/T234/T234.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T234/T234.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: T234 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Lib + build-depends: base, haskell-debugger-view + hs-source-dirs: lib + default-language: Haskell2010 diff --git a/test/golden/T234/T234.ghc-914.hdb-stdout b/test/golden/T234/T234.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T234/T234.ghc-914.hdb-stdout @@ -0,0 +1,7 @@ +[1 of 1] Compiling Lib ( /lib/Lib.hs, interpreted )[T234-0.1.0.0-inplace] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "/lib/Lib.hs", startLine = 16, endLine = 16, startCol = 3, endCol = 14}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +value : ColonList = _ + value : ColonList = alpha:beta:gamma +(hdb) Exiting... diff --git a/test/golden/T234/T234.hdb-stdin b/test/golden/T234/T234.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T234/T234.hdb-stdin @@ -0,0 +1,3 @@ +break lib/Lib.hs 16 +run +variables diff --git a/test/golden/T234/T234.hdb-test b/test/golden/T234/T234.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T234/T234.hdb-test @@ -0,0 +1,3 @@ +#!/bin/sh + +$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T234.hdb-stdin diff --git a/test/golden/T234/lib/Lib.hs b/test/golden/T234/lib/Lib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T234/lib/Lib.hs @@ -0,0 +1,20 @@ +module Lib (mainish) where + +import Data.List (intercalate) +import GHC.Debugger.View.Class + +newtype ColonList = ColonList [String] + deriving Show + +instance DebugView ColonList where + debugValue (ColonList xs) = simpleValue (intercalate ":" xs) False + debugFields _ = pure (VarFields []) + +mainish :: IO () +mainish = do + let value = mkValue + print value + +mkValue :: ColonList +mkValue = ColonList ["alpha", "beta", "gamma"] +{-# OPAQUE mkValue #-} diff --git a/test/golden/T234b/T234b.cabal b/test/golden/T234b/T234b.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T234b/T234b.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: T234b +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Lib + build-depends: base, haskell-debugger-view + hs-source-dirs: lib + default-language: Haskell2010 diff --git a/test/golden/T234b/T234b.ghc-914.hdb-stdout b/test/golden/T234b/T234b.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T234b/T234b.ghc-914.hdb-stdout @@ -0,0 +1,7 @@ +[1 of 1] Compiling Lib ( /lib/Lib.hs, interpreted )[T234b-0.1.0.0-inplace] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Lib 0], sourceSpan = SourceSpan {file = "/lib/Lib.hs", startLine = 18, endLine = 18, startCol = 3, endCol = 14}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +value : ColonList = _ + value : ColonList = This is an IORef! +(hdb) Exiting... diff --git a/test/golden/T234b/T234b.hdb-stdin b/test/golden/T234b/T234b.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T234b/T234b.hdb-stdin @@ -0,0 +1,3 @@ +break lib/Lib.hs 18 +run +variables diff --git a/test/golden/T234b/T234b.hdb-test b/test/golden/T234b/T234b.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T234b/T234b.hdb-test @@ -0,0 +1,1 @@ +$HDB -v0 --entry-point mainish lib/Lib.hs 2>&1 < T234b.hdb-stdin diff --git a/test/golden/T234b/lib/Lib.hs b/test/golden/T234b/lib/Lib.hs new file mode 100644 --- /dev/null +++ b/test/golden/T234b/lib/Lib.hs @@ -0,0 +1,21 @@ +module Lib (mainish) where + +import Data.IORef (IORef, newIORef) +import GHC.Debugger.View.Class + +newtype ColonList = ColonList (IORef [String]) + +instance Show ColonList where + show _ = "" + +instance DebugView ColonList where + debugValue _ = simpleValue "This is an IORef!" False + debugFields _ = pure (VarFields []) + +mainish :: IO () +mainish = do + value <- mkValue + print value + +mkValue :: IO ColonList +mkValue = ColonList <$> newIORef ["alpha", "beta", "gamma"] diff --git a/test/golden/T237/T237.cabal b/test/golden/T237/T237.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T237/T237.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.14 +name: T237 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyType + build-depends: base + hs-source-dirs: lib + default-language: Haskell2010 + +executable T237 + import: warnings + main-is: Main.hs + build-depends: base, T237, haskell-debugger-view + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/golden/T237/T237.ghc-914.hdb-stdout b/test/golden/T237/T237.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T237/T237.ghc-914.hdb-stdout @@ -0,0 +1,16 @@ +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T237-0.1.0.0-inplace-T237] +/app/Main.hs:8:1: warning: [GHC-90177] [-Worphans] + Orphan class instance: instance DebugView MyType + Suggested fix: + Move the instance declaration to the module of the class or of the type, or + wrap the type with a newtype and declare the instance on the new type. + | +8 | instance DebugView MyType where + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^... + +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "/app/Main.hs", startLine = 15, endLine = 15, startCol = 3, endCol = 28}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +value : MyType = _ + value : MyType = alpha:beta:gamma +(hdb) Exiting... diff --git a/test/golden/T237/T237.hdb-stdin b/test/golden/T237/T237.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T237/T237.hdb-stdin @@ -0,0 +1,3 @@ +break app/Main.hs 15 +run +variables diff --git a/test/golden/T237/T237.hdb-test b/test/golden/T237/T237.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T237/T237.hdb-test @@ -0,0 +1,1 @@ +$HDB -v0 app/Main.hs 2>&1 < T237.hdb-stdin || true diff --git a/test/golden/T237/app/Main.hs b/test/golden/T237/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T237/app/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Data.List (intercalate) + +import GHC.Debugger.View.Class +import MyType + +instance DebugView MyType where + debugValue (MyType xs) = simpleValue (intercalate ":" xs) False + debugFields _ = pure (VarFields []) + +main :: IO () +main = do + let value = mkValue + const (print value) value diff --git a/test/golden/T237/lib/MyType.hs b/test/golden/T237/lib/MyType.hs new file mode 100644 --- /dev/null +++ b/test/golden/T237/lib/MyType.hs @@ -0,0 +1,11 @@ +module MyType + ( MyType(..) + , mkValue + ) where + +newtype MyType = MyType [String] + deriving Show + +mkValue :: MyType +mkValue = MyType ["alpha", "beta", "gamma"] +{-# OPAQUE mkValue #-} diff --git a/test/golden/T239/Main.hs b/test/golden/T239/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T239/Main.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -O -fno-unoptimized-core-for-interpreter #-} +{-# LANGUAGE BangPatterns #-} + +module Main where + +data Packed = Packed -- Unpacking only happens with optimizations, hence the -O. + { packedLeft :: {-# UNPACK #-} !Char + , packedRight :: {-# UNPACK #-} !Char + } + deriving Show + +data Container = Container + { containerBefore :: Int + , containerPacked :: {-# UNPACK #-} !Packed + , containerPacked2 :: {-# UNPACK #-} !Packed + , containerAfter :: Int + } + deriving Show + +mkContainer :: Container +mkContainer = Container 10 (Packed 'a' 'b') (Packed 'c' 'd') 40 +{-# OPAQUE mkContainer #-} + +main :: IO () +main = do + let !container = mkContainer + const (pure ()) container + print container diff --git a/test/golden/T239/T239.fails-239.ghc-914.hdb-stdout b/test/golden/T239/T239.fails-239.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T239/T239.fails-239.ghc-914.hdb-stdout @@ -0,0 +1,11 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 2], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 27, endLine = 27, startCol = 3, endCol = 28}} +(hdb) Stopped at breakpoint +(hdb) _result : IO () = :: IO () +container : Container = Container + containerBefore : Int = _ + containerPacked : Packed = Packed + containerPacked2 : Packed = Packed + containerAfter : Int = _ +(hdb) (hdb) Exiting... diff --git a/test/golden/T239/T239.fails-239.hdb-test b/test/golden/T239/T239.fails-239.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T239/T239.fails-239.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T239.hdb-stdin diff --git a/test/golden/T239/T239.hdb-stdin b/test/golden/T239/T239.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T239/T239.hdb-stdin @@ -0,0 +1,4 @@ +break Main.hs 27 +run +variables +exit diff --git a/test/golden/T242/Main.hs b/test/golden/T242/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T242/Main.hs @@ -0,0 +1,12 @@ +f () = do + let xs = [3,2,1] + pure () + print xs + +main = do + let doit = const (pure () :: IO ()) + let xs = [4,5,6] + doit () + f () + print xs + putStrLn "done" diff --git a/test/golden/T242/T242.ghc-914.hdb-stdout b/test/golden/T242/T242.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T242/T242.ghc-914.hdb-stdout @@ -0,0 +1,14 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 9, endLine = 9, startCol = 3, endCol = 10}} +(hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 11], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 3, endLine = 3, startCol = 3, endCol = 10}} +(hdb) Stopped at breakpoint +(hdb) Aborted: :1:8: error: [GHC-88464] + Variable not in scope: sort :: [Integer] -> a0 +(hdb) +(hdb) [4,5,6] +() +(hdb) Stopped at breakpoint +(hdb) [1,2,3] +() +(hdb) Exiting... diff --git a/test/golden/T242/T242.hdb-stdin b/test/golden/T242/T242.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T242/T242.hdb-stdin @@ -0,0 +1,8 @@ +break Main.hs 9 +break Main.hs 3 +run +print print (sort xs) +print import Data.List +print print (sort xs) +continue +print print (sort xs) diff --git a/test/golden/T242/T242.hdb-test b/test/golden/T242/T242.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T242/T242.hdb-test @@ -0,0 +1,1 @@ +$HDB Main.hs -v 0 < T242.hdb-stdin diff --git a/test/golden/T283/T283.cabal b/test/golden/T283/T283.cabal new file mode 100644 --- /dev/null +++ b/test/golden/T283/T283.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.16 +name: T283 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable T283 + import: warnings + main-is: Main.hs + build-depends: base + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/golden/T283/T283.ghc-914.hdb-stdout b/test/golden/T283/T283.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T283/T283.ghc-914.hdb-stdout @@ -0,0 +1,10 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283] +(hdb) +(hdb) THIS IS A PACKAGE +() +(hdb) Aborted: :1:1: error: [GHC-35235] + Could not find module `Main'. + It is not a module in the current program, or in any known package. +(hdb) "If an older version of T283 was installed, we'd now shadow the home-unit Main with the outdated installed Main!" +(hdb) Exiting... diff --git a/test/golden/T283/T283.hdb-stdin b/test/golden/T283/T283.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/T283/T283.hdb-stdin @@ -0,0 +1,4 @@ +p import Main +p main +p import "T283" Main +p "If an older version of T283 was installed, we'd now shadow the home-unit Main with the outdated installed Main!" diff --git a/test/golden/T283/T283.hdb-test b/test/golden/T283/T283.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/T283/T283.hdb-test @@ -0,0 +1,4 @@ +#!/bin/sh + +# Witnesses that package-qualified imports bypass home units (#283) +$HDB -v0 app/Main.hs 2>&1 < T283.hdb-stdin diff --git a/test/golden/T283/app/Main.hs b/test/golden/T283/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/T283/app/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "THIS IS A PACKAGE" diff --git a/test/golden/T61/T61.ghc-914.hdb-stdout b/test/golden/T61/T61.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T61/T61.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /x/Main.hs, interpreted )[main] +(hdb) wrks +() +(hdb) Exiting... diff --git a/test/golden/T61/T61.ghc-915.hdb-stdout b/test/golden/T61/T61.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T61/T61.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /x/Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) wrks +() +(hdb) Exiting... diff --git a/test/golden/T61/T61.hdb-stdout b/test/golden/T61/T61.hdb-stdout deleted file mode 100644 --- a/test/golden/T61/T61.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /x/Main.hs, interpreted )[main] -(hdb) wrks -() -(hdb) Exiting... diff --git a/test/golden/T79/T79.ghc-914.hdb-stdout b/test/golden/T79/T79.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T79/T79.ghc-914.hdb-stdout @@ -0,0 +1,14 @@ +[Info] Using cabal specification: +[Warn] unknown license type, you must put a copy in LICENSE yourself. +[Info] Creating fresh file CHANGELOG.md... +[Info] Creating fresh directory ./app... +[Info] Creating fresh file app/Main.hs... +[Info] Creating fresh file T79-tmp.cabal... +[Warn] No synopsis given. You should edit the .cabal file and add one. +[Info] You may want to edit the .cabal file and add a Description field. + +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] +(hdb) Hello, Haskell! +() +(hdb) Exiting... diff --git a/test/golden/T79/T79.ghc-915.hdb-stdout b/test/golden/T79/T79.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T79/T79.ghc-915.hdb-stdout @@ -0,0 +1,14 @@ +[Info] Using cabal specification: +[Warn] unknown license type, you must put a copy in LICENSE yourself. +[Info] Creating fresh file CHANGELOG.md... +[Info] Creating fresh directory ./app... +[Info] Creating fresh file app/Main.hs... +[Info] Creating fresh file T79-tmp.cabal... +[Warn] No synopsis given. You should edit the .cabal file and add one. +[Info] You may want to edit the .cabal file and add a Description field. + +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /app/Main.hs, /.hdb-cache//Main.gbc )[T79-tmp-0.1.0.0-inplace-T79-tmp] +(hdb) Hello, Haskell! +() +(hdb) diff --git a/test/golden/T79/T79.hdb-stdout b/test/golden/T79/T79.hdb-stdout deleted file mode 100644 --- a/test/golden/T79/T79.hdb-stdout +++ /dev/null @@ -1,14 +0,0 @@ -[Info] Using cabal specification: -[Warn] unknown license type, you must put a copy in LICENSE yourself. -[Info] Creating fresh file CHANGELOG.md... -[Info] Creating fresh directory ./app... -[Info] Creating fresh file app/Main.hs... -[Info] Creating fresh file T79-tmp.cabal... -[Warn] No synopsis given. You should edit the .cabal file and add one. -[Info] You may want to edit the .cabal file and add a Description field. - -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] -(hdb) Hello, Haskell! -() -(hdb) diff --git a/test/golden/T83/T83.ghc-914.hdb-stdout b/test/golden/T83/T83.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T83/T83.ghc-914.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +(hdb) Heli +() +(hdb) Exiting... diff --git a/test/golden/T83/T83.ghc-915.hdb-stdout b/test/golden/T83/T83.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/T83/T83.ghc-915.hdb-stdout @@ -0,0 +1,5 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) Heli +() +(hdb) Exiting... diff --git a/test/golden/T83/T83.hdb-stdout b/test/golden/T83/T83.hdb-stdout deleted file mode 100644 --- a/test/golden/T83/T83.hdb-stdout +++ /dev/null @@ -1,5 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] -(hdb) Heli -() -(hdb) Exiting... diff --git a/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout @@ -0,0 +1,23 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw first +Stopped at breakpoint +Exception: ErrorCall +Message: boom first +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:8:10 +(hdb) Handled first exception: boom first +Continuing after first exception +Stopped at breakpoint +Exception: ErrorCall +Message: boom second +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:10:3 in main:Main + +Exception location: /prog/Main.hs:10:3 +(hdb) Exiting... diff --git a/test/golden/exceptions-multiple/exceptions-multiple.ghc-915.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-multiple/exceptions-multiple.ghc-915.hdb-stdout @@ -0,0 +1,23 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw first +Stopped at breakpoint +Exception: ErrorCall +Message: boom first +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:8:10 +(hdb) Handled first exception: boom first +Continuing after first exception +Stopped at breakpoint +Exception: ErrorCall +Message: boom second +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:10:3 in main:Main + +Exception location: /prog/Main.hs:10:3 +(hdb) diff --git a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout deleted file mode 100644 --- a/test/golden/exceptions-multiple/exceptions-multiple.hdb-stdout +++ /dev/null @@ -1,23 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] -(hdb) BreakFoundNoLoc {changed = True} -(hdb) About to throw first -Stopped at breakpoint -Exception: ErrorCall -Message: boom first -Call stack: - HasCallStack backtrace: - error, called at /prog/Main.hs:8:10 in main:Main - -Exception location: /prog/Main.hs:8:10 -(hdb) Handled first exception: boom first -Continuing after first exception -Stopped at breakpoint -Exception: ErrorCall -Message: boom second -Call stack: - HasCallStack backtrace: - error, called at /prog/Main.hs:10:3 in main:Main - -Exception location: /prog/Main.hs:10:3 -(hdb) diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout @@ -0,0 +1,22 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Handling exception: boom outer +Stopped at breakpoint +Exception: ErrorCall +Message: boom while handling +Call stack: + While handling boom outer + + HasCallStack backtrace: + error, called at /prog/Main.hs:14:3 in main:Main +Inner exceptions: + Exception: ErrorCall + Message: boom outer + Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:14:3 +(hdb) Exiting... diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-915.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-915.hdb-stdout @@ -0,0 +1,22 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Handling exception: boom outer +Stopped at breakpoint +Exception: ErrorCall +Message: boom while handling +Call stack: + While handling boom outer + + HasCallStack backtrace: + error, called at /prog/Main.hs:14:3 in main:Main +Inner exceptions: + Exception: ErrorCall + Message: boom outer + Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:8:10 in main:Main + +Exception location: /prog/Main.hs:14:3 +(hdb) diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout deleted file mode 100644 --- a/test/golden/exceptions-uncaught/exceptions-uncaught.hdb-stdout +++ /dev/null @@ -1,22 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] -(hdb) BreakFoundNoLoc {changed = True} -(hdb) About to throw -Handling exception: boom outer -Stopped at breakpoint -Exception: ErrorCall -Message: boom while handling -Call stack: - While handling boom outer - - HasCallStack backtrace: - error, called at /prog/Main.hs:14:3 in main:Main -Inner exceptions: - Exception: ErrorCall - Message: boom outer - Call stack: - HasCallStack backtrace: - error, called at /prog/Main.hs:8:10 in main:Main - -Exception location: /prog/Main.hs:14:3 -(hdb) diff --git a/test/golden/exceptions/exceptions.ghc-914.hdb-stdout b/test/golden/exceptions/exceptions.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/exceptions.ghc-914.hdb-stdout @@ -0,0 +1,13 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Stopped at breakpoint +Exception: ErrorCall +Message: boom +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:6:3 in main:Main + +Exception location: /prog/Main.hs:6:3 +(hdb) Exiting... diff --git a/test/golden/exceptions/exceptions.ghc-915.hdb-stdout b/test/golden/exceptions/exceptions.ghc-915.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/exceptions/exceptions.ghc-915.hdb-stdout @@ -0,0 +1,13 @@ +[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, in-memory:GHC.Debugger.View.gbc )[haskell-debugger-view-in-memory] +[2 of 3] Compiling Main ( /prog/Main.hs, /.hdb-cache//Main.gbc )[main] +(hdb) BreakFoundNoLoc {changed = True} +(hdb) About to throw +Stopped at breakpoint +Exception: ErrorCall +Message: boom +Call stack: + HasCallStack backtrace: + error, called at /prog/Main.hs:6:3 in main:Main + +Exception location: /prog/Main.hs:6:3 +(hdb) diff --git a/test/golden/exceptions/exceptions.hdb-stdout b/test/golden/exceptions/exceptions.hdb-stdout deleted file mode 100644 --- a/test/golden/exceptions/exceptions.hdb-stdout +++ /dev/null @@ -1,13 +0,0 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] -(hdb) BreakFoundNoLoc {changed = True} -(hdb) About to throw -Stopped at breakpoint -Exception: ErrorCall -Message: boom -Call stack: - HasCallStack backtrace: - error, called at /prog/Main.hs:6:3 in main:Main - -Exception location: /prog/Main.hs:6:3 -(hdb) diff --git a/test/golden/self-debug-cli/Main.hs b/test/golden/self-debug-cli/Main.hs new file mode 100644 --- /dev/null +++ b/test/golden/self-debug-cli/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Running this program inside the debugger(which is running inside the debugger)" diff --git a/test/golden/self-debug-cli/self-debug-cli.hdb-stdin b/test/golden/self-debug-cli/self-debug-cli.hdb-stdin new file mode 100644 --- /dev/null +++ b/test/golden/self-debug-cli/self-debug-cli.hdb-stdin @@ -0,0 +1,5 @@ +break --name runDebugger +run cli test/golden/self-debug-cli/Main.hs +print mkFastString "this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS)." +print mkFastString "We have a DebugView FastString instance at this breakpoint." +exit diff --git a/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout new file mode 100644 --- /dev/null +++ b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout @@ -0,0 +1,56 @@ +[ 1 of 53] Compiling Development.Debug.Adapter.Handles ( /hdb/Development/Debug/Adapter/Handles.hs, interpreted )[haskell-debugger--inplace-hdb] +[ 2 of 53] Compiling Development.Debug.Options ( /hdb/Development/Debug/Options.hs, interpreted )[haskell-debugger--inplace-hdb] +[ 3 of 53] Compiling Development.Debug.Session.Setup ( /hdb/Development/Debug/Session/Setup.hs, interpreted )[haskell-debugger--inplace-hdb] +[ 4 of 53] Compiling GHC.Debugger.Breakpoint.Map ( /haskell-debugger/GHC/Debugger/Breakpoint/Map.hs, interpreted )[haskell-debugger--inplace] +[ 5 of 53] Compiling GHC.Debugger.Runtime.Compile.Cache ( /haskell-debugger/GHC/Debugger/Runtime/Compile/Cache.hs, interpreted )[haskell-debugger--inplace] +[ 6 of 53] Compiling GHC.Debugger.Runtime.Term.Key ( /haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs, interpreted )[haskell-debugger--inplace] +[ 7 of 53] Compiling GHC.Debugger.Interface.Messages ( /haskell-debugger/GHC/Debugger/Interface/Messages.hs, interpreted )[haskell-debugger--inplace] +[ 8 of 53] Compiling GHC.Debugger.Runtime.Interpreter.Custom ( /haskell-debugger/GHC/Debugger/Runtime/Interpreter/Custom.hs, interpreted )[haskell-debugger--inplace] +[ 9 of 53] Compiling Development.Debug.Adapter ( /hdb/Development/Debug/Adapter.hs, interpreted )[haskell-debugger--inplace-hdb] +[10 of 53] Compiling Development.Debug.Adapter.Proxy ( /hdb/Development/Debug/Adapter/Proxy.hs, interpreted )[haskell-debugger--inplace-hdb] +[11 of 53] Compiling Development.Debug.Adapter.Output ( /hdb/Development/Debug/Adapter/Output.hs, interpreted )[haskell-debugger--inplace-hdb] +[12 of 53] Compiling Development.Debug.Adapter.Interface ( /hdb/Development/Debug/Adapter/Interface.hs, interpreted )[haskell-debugger--inplace-hdb] +[13 of 53] Compiling Development.Debug.Adapter.Stopped ( /hdb/Development/Debug/Adapter/Stopped.hs, interpreted )[haskell-debugger--inplace-hdb] +[14 of 53] Compiling Development.Debug.Adapter.Exit.Helpers ( /hdb/Development/Debug/Adapter/Exit/Helpers.hs, interpreted )[haskell-debugger--inplace-hdb] +[15 of 53] Compiling Development.Debug.Adapter.Exit ( /hdb/Development/Debug/Adapter/Exit.hs, interpreted )[haskell-debugger--inplace-hdb] +[16 of 53] Compiling Development.Debug.Adapter.ExceptionInfo ( /hdb/Development/Debug/Adapter/ExceptionInfo.hs, interpreted )[haskell-debugger--inplace-hdb] +[17 of 53] Compiling Development.Debug.Adapter.Evaluation ( /hdb/Development/Debug/Adapter/Evaluation.hs, interpreted )[haskell-debugger--inplace-hdb] +[18 of 53] Compiling Development.Debug.Adapter.Stepping ( /hdb/Development/Debug/Adapter/Stepping.hs, interpreted )[haskell-debugger--inplace-hdb] +[19 of 53] Compiling Development.Debug.Adapter.Breakpoints ( /hdb/Development/Debug/Adapter/Breakpoints.hs, interpreted )[haskell-debugger--inplace-hdb] +[20 of 53] Compiling GHC.Debugger.Runtime.Thread.Map ( /haskell-debugger/GHC/Debugger/Runtime/Thread/Map.hs, interpreted )[haskell-debugger--inplace] +[21 of 53] Compiling GHC.Debugger.Session ( /haskell-debugger/GHC/Debugger/Session.hs, interpreted )[haskell-debugger--inplace] +[22 of 53] Compiling GHC.Debugger.Session.Builtin ( /haskell-debugger/GHC/Debugger/Session/Builtin.hs, interpreted )[haskell-debugger--inplace] +[23 of 53] Compiling GHC.Debugger.Session.Interactive ( /haskell-debugger/GHC/Debugger/Session/Interactive.hs, interpreted )[haskell-debugger--inplace] +[24 of 53] Compiling GHC.Debugger.Utils ( /haskell-debugger/GHC/Debugger/Utils.hs, interpreted )[haskell-debugger--inplace] +[25 of 53] Compiling GHC.Debugger.View.Class ( /haskell-debugger-view/src/GHC/Debugger/View/Class.hs, interpreted )[haskell-debugger-view--inplace] +[26 of 53] Compiling GHC.Debugger.View.ByteString ( /haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs, interpreted )[haskell-debugger-view--inplace] +[27 of 53] Compiling GHC.Debugger.Utils.Orphans ( /haskell-debugger/GHC/Debugger/Utils/Orphans.hs, interpreted )[haskell-debugger--inplace] +[28 of 53] Compiling GHC.Debugger.Runtime.Instances.Discover[boot] ( /haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs-boot, interpreted )[haskell-debugger--inplace] +[29 of 53] Compiling GHC.Debugger.Monad ( /haskell-debugger/GHC/Debugger/Monad.hs, interpreted )[haskell-debugger--inplace] +[30 of 53] Compiling GHC.Debugger.Runtime.Instances.Discover ( /haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs, interpreted )[haskell-debugger--inplace] +[31 of 53] Compiling GHC.Debugger.Runtime.Eval ( /haskell-debugger/GHC/Debugger/Runtime/Eval.hs, interpreted )[haskell-debugger--inplace] +[32 of 53] Compiling GHC.Debugger.Runtime.Compile ( /haskell-debugger/GHC/Debugger/Runtime/Compile.hs, interpreted )[haskell-debugger--inplace] +[33 of 53] Compiling GHC.Debugger.Runtime.Eval.RemoteExpr ( /haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs, interpreted )[haskell-debugger--inplace] +[34 of 53] Compiling GHC.Debugger.Runtime.Term.Parser ( /haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs, interpreted )[haskell-debugger--inplace] +[35 of 53] Compiling GHC.Debugger.Runtime.Instances ( /haskell-debugger/GHC/Debugger/Runtime/Instances.hs, interpreted )[haskell-debugger--inplace] +[36 of 53] Compiling GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin ( /haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs, interpreted )[haskell-debugger--inplace] +[37 of 53] Compiling GHC.Debugger.Runtime.Thread.Stack ( /haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs, interpreted )[haskell-debugger--inplace] +[38 of 53] Compiling GHC.Debugger.Runtime.Thread ( /haskell-debugger/GHC/Debugger/Runtime/Thread.hs, interpreted )[haskell-debugger--inplace] +[39 of 53] Compiling GHC.Debugger.Stopped.Exception ( /haskell-debugger/GHC/Debugger/Stopped/Exception.hs, interpreted )[haskell-debugger--inplace] +[40 of 53] Compiling GHC.Debugger.Runtime ( /haskell-debugger/GHC/Debugger/Runtime.hs, interpreted )[haskell-debugger--inplace] +[41 of 53] Compiling GHC.Debugger.Stopped.Variables ( /haskell-debugger/GHC/Debugger/Stopped/Variables.hs, interpreted )[haskell-debugger--inplace] +[42 of 53] Compiling GHC.Debugger.Stopped ( /haskell-debugger/GHC/Debugger/Stopped.hs, interpreted )[haskell-debugger--inplace] +[43 of 53] Compiling GHC.Debugger.Run ( /haskell-debugger/GHC/Debugger/Run.hs, interpreted )[haskell-debugger--inplace] +[44 of 53] Compiling GHC.Debugger.Breakpoint ( /haskell-debugger/GHC/Debugger/Breakpoint.hs, interpreted )[haskell-debugger--inplace] +[45 of 53] Compiling GHC.Debugger ( /haskell-debugger/GHC/Debugger.hs, interpreted )[haskell-debugger--inplace] +[46 of 53] Compiling Development.Debug.Interactive ( /hdb/Development/Debug/Interactive.hs, interpreted )[haskell-debugger--inplace-hdb] +[47 of 53] Compiling Development.Debug.Adapter.Init ( /hdb/Development/Debug/Adapter/Init.hs, interpreted )[haskell-debugger--inplace-hdb] +[48 of 53] Compiling GHC.Debugger.View.Containers ( /haskell-debugger-view/src/GHC/Debugger/View/Containers.hs, interpreted )[haskell-debugger-view--inplace] +[49 of 53] Compiling GHC.Debugger.View.Text ( /haskell-debugger-view/src/GHC/Debugger/View/Text.hs, interpreted )[haskell-debugger-view--inplace] +[50 of 53] Compiling Paths_haskell_debugger ( /Paths_haskell_debugger.hs, interpreted )[haskell-debugger--inplace-hdb] +[51 of 53] Compiling Development.Debug.Options.Parser ( /hdb/Development/Debug/Options/Parser.hs, interpreted )[haskell-debugger--inplace-hdb] +[52 of 53] Compiling Main ( /hdb/Main.hs, interpreted )[haskell-debugger--inplace-hdb] +(hdb) Stopped at breakpoint +(hdb) this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS). +(hdb) We have a DebugView FastString instance at this breakpoint. +(hdb) Exiting... diff --git a/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test new file mode 100644 --- /dev/null +++ b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test @@ -0,0 +1,34 @@ +#!/bin/sh + +# 1) Run only in .external mode because there are some issues in loading ghc into +# itself with the internal interpreter. Didn't investigate thoroughly. +# +# 2) Since this test is named `....no-tmp-dir....` then it will be run in the root of the tree +# +# 3) Grep out the `BreakFound` word. It doesn't matter for the test and it is +# too prone to changing because it reports source lines of the actual debugger +# source, which we change all the time (unlike testsuite programs). +# +# 4) Normalize cabal autogen paths (e.g. `Paths_haskell_debugger.hs`). +# It's not immediately clear why these go in .cache/hie-bios/... rather than in +# $HDB_CACHE_DIR, but I guess it's an autogen thing rather than the actual +# compilation artifacts cache (.hi, ...) +# +# 5) When testing the sdist (just the packaged things), the root doesn't have a hie.yaml. +# Add one temporarily +created_yaml=false +if [ ! -f hie.yaml ]; then + echo 'cradle:\n cabal:\n component: "all"' > hie.yaml + created_yaml=true; +fi + +$HDB -v0 hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \ + | grep -v "BreakFound" \ + | sed \ + -e 's|[^ ]*/Paths_haskell_debugger.hs|/Paths_haskell_debugger.hs|g' \ + -e 's|haskell-debugger-[0-9.][0-9.]*-inplace|haskell-debugger--inplace|g' \ + -e 's|haskell-debugger-view-[0-9.][0-9.]*-inplace|haskell-debugger-view--inplace|g' + +if [ $created_yaml = true ]; then + rm hie.yaml +fi diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes, CPP #-} module Main (main) where -import Data.List (isSuffixOf) +import Data.List (isSuffixOf, isInfixOf) import qualified Data.Set as Set import Text.RE.TDFA.Text.Lazy import Text.Printf @@ -10,6 +10,7 @@ import qualified Data.Text.Lazy.IO as LT import qualified Data.ByteString.Lazy.Char8 as LBS import qualified System.Process as P +import System.Directory import System.FilePath import qualified System.FilePath.Posix as Posix import System.IO.Temp @@ -23,14 +24,35 @@ import Test.Tasty.Golden as G import Test.Tasty.Golden.Advanced as G -import Test.DAP.RunInTerminal +import Test.Integration.LogMessage (logMessageTests) +import Test.Integration.Persistent (persistentTests) +import Test.Integration.RunInTerminal (runInTerminalTests) +import Test.Integration.Scopes (scopesTests) +import Test.Integration.Basic (basicTests) +import Test.Integration.Exceptions (exceptionTests) +import Test.Integration.MultiMain (multiMainTests) +import Test.Integration.MultiHomeUnit (multiHomeUnitTests) +import Test.Integration.Variables (variableTests) +import Test.Integration.StepOut (stepOutTests) +import Test.Integration.Stdout (stdoutTests) +import Test.Integration.Conditional (conditionalTests) +import Test.Integration.Evaluate (evaluateTests) +import Test.Integration.StackTrace (stackTraceTests) import Test.Utils +import qualified Data.Char as C +import qualified Data.Text as T main :: IO () main = do env <- getEnvironment - let mkTest = mkGoldenTest False env + let mkTest = mkGoldenTest (maybe False read (lookup "KEEP_TEMP_DIRS" env)) env golden_tests_paths <- findByExtension [".hdb-test"] "test/golden" + `catch` \(e::IOException) -> do + hPutStrLn stderr "-- !! ERROR !! -----------------------------------------------------------------" + hPutStrLn stderr "Failed to find golden tests by `*.hdb-test` extension." + hPutStrLn stderr "Make sure that the testsuite is being run from the project root (where the relative path `test/golden` is valid)." + hPutStrLn stderr "--------------------------------------------------------------------------------" + throwIO e let internalOnlyTests = filter (\p -> ".internal" `isSuffixOf` takeBaseName p) golden_tests_paths let externalOnlyTests = filter (\p -> ".external" `isSuffixOf` takeBaseName p) golden_tests_paths @@ -50,8 +72,8 @@ -- (since they run as separate processes). To use a single golden test file for -- both modes, we disable IPE backtraces by default in tests. let baseFlags = "--disable-ipe-backtraces" - default_goldens <- mapM (mkTest baseFlags) testsForExternal - intinterp_goldens <- mapM (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal + let default_goldens = map (mkTest baseFlags) testsForExternal + let intinterp_goldens = map (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal defaultMain $ testGroup "Tests" @@ -67,31 +89,54 @@ unitTests :: [TestTree] unitTests = [ runInTerminalTests + , scopesTests + , logMessageTests + , persistentTests + , basicTests + , exceptionTests + , multiMainTests + , multiHomeUnitTests + , variableTests + , stepOutTests + , stdoutTests + , conditionalTests + , evaluateTests + , stackTraceTests ] -- | Receives as an argument the path to the @*.hdb-test@ which contains the -- shell invocation for running -mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> IO TestTree -mkGoldenTest keepTmpDirs inheritedEnv flags path = do - let testName = takeBaseName path - let goldenPath = replaceExtension path ".hdb-stdout" - return $ goldenVsStringComparing testName goldenPath action +mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> TestTree +mkGoldenTest keepTmpDirs inheritedEnv flags path = goldenVsStringComparing testName goldenPath topAction where - action :: IO LBS.ByteString - action = do - withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do - (_, Just hout, _, p) - <- P.createProcess (P.proc "sh" [takeFileName path]) - { P.cwd = Just test_dir, P.std_out = P.CreatePipe - , P.env = Just $ - inheritedEnv ++ - [ ("HDB", "hdb " ++ flags) - ] - } - P.waitForProcess p >>= \case - ExitSuccess -> LBS.hGetContents hout - ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c + ghcVersionTag :: String + ghcVersionTag = show (__GLASGOW_HASKELL__ :: Int) + testName = takeBaseName path + goldenPath = replaceExtension path (".ghc-" ++ ghcVersionTag ++ ".hdb-stdout") + + noTmpDir = ".no-tmp-dir" `isInfixOf` testName + + topAction :: IO LBS.ByteString + topAction | noTmpDir = testAction path =<< getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test + | otherwise = withHermeticDir keepTmpDirs (takeDirectory path) (testAction (takeFileName path)) + + + testAction :: FilePath -> FilePath -> IO LBS.ByteString + testAction test_path test_dir = do + (_, Just hout, _, p) + <- P.createProcess (P.proc "sh" [test_path]) + { P.cwd = Just test_dir, P.std_out = P.CreatePipe + , P.env = Just $ + inheritedEnv ++ + [ ("HDB_CACHE_DIR", test_dir ".hdb-cache") + , ("HDB", "hdb " ++ flags) + ] + } + P.waitForProcess p >>= \case + ExitSuccess -> LBS.hGetContents hout + ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c + -------------------------------------------------------------------------------- -- Tasty Golden Advanced wrapper -------------------------------------------------------------------------------- @@ -106,10 +151,11 @@ -- ^ action that returns a string -> TestTree -- ^ the test verifies that the returned string is the same as the golden file contents -goldenVsStringComparing name ref act = do +goldenVsStringComparing name ref act = - -- Normalise the output. The test file should already be saved normalised. - goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd + maybeExpectFail $ + -- Normalise the output. The test file should already be saved normalised. + goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd where upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8 @@ -133,6 +179,7 @@ -- Normalise the action producing the output normalisingAct = do tmpDir <- getCanonicalTemporaryDirectory + cwd <- getCurrentDirectory let winTempDirWithForwardSlashes = useForwardSlashes tmpDir let posixTempDirRegex = @@ -149,6 +196,10 @@ , ( "\\\\", "/" ) -- Use forward slash , ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-} , "" ) + , ( "\\.hdb-cache/[^/]+/" + , ".hdb-cache//" ) + , ( escapeRegex cwd + , "" ) ] let normalising (LT.decodeUtf8 -> txt) = LT.filter (/= '\r') $ foldl' (*=~/) txt replaceREs @@ -163,6 +214,13 @@ forceLbs :: LBS.ByteString -> () forceLbs = LBS.foldr seq () + + -- if testname contains `.fails-234` we expect a failure described by ticket #234 + maybeExpectFail = case T.breakOn ".fails-" (T.pack name) of + (_, rest) + | let num = T.takeWhile C.isDigit (T.drop (T.length ".fails-") rest) + , not (T.null num) -> expectFailBecause ("#" ++ T.unpack num) + | otherwise -> id -------------------------------------------------------------------------------- -- Normalisation diff --git a/test/haskell/Test/DAP.hs b/test/haskell/Test/DAP.hs --- a/test/haskell/Test/DAP.hs +++ b/test/haskell/Test/DAP.hs @@ -1,122 +1,584 @@ --- | Utils essentially copied from `dap`'s test suite +{-# LANGUAGE CPP #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} -module Test.DAP where +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -import Control.Applicative -import Control.Concurrent -import Data.Aeson.Encode.Pretty -import Data.Aeson.Types -import Data.Aeson.KeyMap -import Control.Exception hiding (handle) -import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as B8 ( hPutStrLn ) +module Test.DAP + ( module Test.DAP + , module Test.DAP.Init + , module Test.DAP.Messages + ) where + +import qualified Data.Map as M +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Data.Aeson +import Control.Monad.Reader +import Test.DAP.Init +import Test.DAP.Messages +import Test.DAP.Messages.Parser +import Control.Concurrent.Async +import Control.Monad.Cont +import Control.Monad +import Data.Maybe import qualified Data.HashMap.Strict as H -import Network.Run.TCP -import Network.Socket (socketToHandle) -import System.IO -import System.Exit -import Data.IORef ----------------------------------------------------------------------------- -import DAP.Utils -import DAP.Server -import DAP.Types (Command) ----------------------------------------------------------------------------- -import Test.Tasty.HUnit +import System.FilePath +import qualified Data.Text as T +import Data.Aeson.Types +import Test.Tasty.HUnit +import DAP (ScopesArguments(..), StackTraceArguments(..), DisconnectArguments(..)) +import qualified DAP +import Test.DAP.Orphans () +import DAP.Types --- | Sends a DAP request to the given handle -sendDAPRequest :: ToJSON a => Handle -> Command -> a -> IO () -sendDAPRequest handle cmd args = do - send handle - [ "seq" .= (1 :: Int) - , "type" .= ("request" :: String) - , "command" .= cmd - , "arguments".= args - ] +import qualified Data.List as List --- | Receive and decode DAP message -recvDAPResponse - :: FromJSON a - => Handle - -- ^ Handle to receive bytes from - -> IO a - -- ^ The decoded DAP message -recvDAPResponse h = do - readPayload h >>= \case - Left e -> fail e - Right actual -> - -- Read field "body" or "arguments" (for reverse requests) - case parseMaybe (withObject "response/rev request" $ \r -> (do - ("response" :: String) <- r .: "type" - True <- r .: "success" - r .: "body") <|> (do - ("request" :: String) <- r .: "type" - r .: "arguments") - ) actual of - Nothing -> fail $ "Failed to parse DAP response body: " ++ show actual - Just body -> - case parseMaybe parseJSON body of - Nothing -> fail $ "Failed to parse DAP response body content: " ++ show body - Just res -> pure res +-------------------------------------------------------------------------------- +-- * DSL +-------------------------------------------------------------------------------- +-- fill as needed; some parts of the highest level DSL will prefer NOT to be sync. +next, stepIn :: TestDAP () +next = void . sync $ nextRequest @Value @Value Null +stepIn = void . sync $ stepInRequest @Value @Value Null + +threads :: TestDAP [Thread] +threads = do + Response{responseBody=Just ThreadsResponse{threads=ts}} <- sync threadsRequest + return ts + +stackTrace :: Int -> TestDAP [StackFrame] +stackTrace tid = do + Response{responseBody=Just StackTraceResponse{stackFrames=fs}} <- sync $ stackTraceRequest $ + StackTraceArguments + { DAP.stackTraceArgumentsThreadId = tid + , DAP.stackTraceArgumentsStartFrame = Nothing + , DAP.stackTraceArgumentsLevels = Nothing + , DAP.stackTraceArgumentsFormat = Nothing + } + return fs + +scopes :: Int {- stack frame id -} -> TestDAP [Scope] +scopes frameId = do + Response{responseBody=Just ScopesResponse{scopes=scs}} <- sync $ scopesRequest $ + ScopesArguments { DAP.scopesArgumentsFrameId = frameId } + return scs + +configurationDone :: ResponseCont Value a -> TestDAP a +configurationDone = configurationDoneRequest Nothing + -------------------------------------------------------------------------------- +-- ** "Scenarios" +-------------------------------------------------------------------------------- --- | Sample host shared amongst client and server --- -testHost :: String -testHost = "127.0.0.1" +-- | Register handler that will reply to runInTerminal reverse request +handleRunInTerminal :: AsyncCont (Maybe (H.HashMap T.Text T.Text), [T.Text]) (a, Int) + -- ^ Continuation receives async with args of runInTerm req. + -- + -- - Waiting means block waiting for reverse request to be received + -- - Returns the process id of the launched runInTerminal process. + -> TestDAP a +handleRunInTerminal k = do + ctx <- ask + liftIO $ + withAsync (upd <$> runTestDAP waitForReverseRequest ctx) $ \a -> + runTestDAP (k a >>= \(x, pid) -> do + respondWithBody 0{-hardcode seqn-} "runInTerminal" (object [ "shellProcessId" .= pid ]) + return x + ) ctx + where + upd :: Value -> (Maybe (H.HashMap T.Text T.Text), [T.Text]) + upd orig = + fromMaybe (error $ "Failed to parse runInTerminal request: " ++ show orig) $ + parseMaybe parser orig --- | Spawns a new mock client that connects to the mock server. --- -withNewClient :: Int -- ^ Port - -> IORef Bool - -- ^ True if we've already connected once and therefore should no longer retry - -> (Handle -> IO ()) - -> IO () -withNewClient port retryVar continue = flip catch exceptionHandler $ - runTCPClient testHost (show port) $ \socket -> do - h <- socketToHandle socket ReadWriteMode - hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF } - continue h `finally` hClose h - where - exceptionHandler :: SomeException -> IO () - exceptionHandler e = do - do_retry <- readIORef retryVar - if do_retry then do - threadDelay 100_000 -- 0.1s - -- Do it silently: - -- putStrLn "Retrying connection..." - withNewClient port retryVar continue - else do - putStrLn $ displayException e - exitWith (ExitFailure 22) + parser :: Value -> Parser (Maybe (H.HashMap T.Text T.Text), [T.Text]) + parser = withObject "runInTerminal request" $ \o -> do + ("request" :: String) <- o .: "type" + ("runInTerminal" :: String) <- o .: "command" + argsObj <- o .: "arguments" + withObject "runInTerminal arguments" (\a -> do + env :: Maybe (H.HashMap T.Text T.Text) <- a .:? "env" + args :: [T.Text] <- a .: "args" + pure (env, args) + ) argsObj --- | Helper to send JSON payloads to the server --- -send :: Handle -> [Pair] -> IO () -send h message - = BS.hPutStr h $ encodeBaseProtocolMessage (object message) +-- | Launch a config, run to completion and assert the exit code. +runToEnd :: LaunchConfig -> TestDAP () +runToEnd cfg = do + _ <- sync $ launchWith cfg + waitFiltering_ EventTy "initialized" + _ <- sync configurationDone + waitForExitCode 0 --- | Helper to receive JSON payloads to the client --- checks if 'Handle' returns a subset expected payload +-------------------------------------------------------------------------------- +-- ** Custom launch configs +-------------------------------------------------------------------------------- + +-- | Launch configuration for the debugger. Mirrors the NodeJS test config. +data LaunchConfig = LaunchConfig + { lcProjectRoot :: FilePath + , lcEntryFile :: Maybe FilePath + , lcEntryPoint :: Maybe String + , lcEntryArgs :: [String] + , lcExtraGhcArgs :: [String] + , lcInternalInterpreter :: Maybe Bool + } + +-- | A launch config with the given project root and entry file. @entryPoint@ +-- defaults to @main@ and there are no extra args. +mkLaunchConfig :: FilePath -> FilePath -> LaunchConfig +mkLaunchConfig projectRoot entryFile = LaunchConfig + { lcProjectRoot = projectRoot + , lcEntryFile = Just entryFile + , lcEntryPoint = Just "main" + , lcEntryArgs = [] + , lcExtraGhcArgs = [] + , lcInternalInterpreter = Nothing + } + +-- | Launch the debugger with a 'LaunchConfig'. +launchWith :: LaunchConfig -> ResponseCont Value a -> TestDAP a +launchWith LaunchConfig{..} = launch $ object $ + [ "projectRoot" .= lcProjectRoot + , "request" .= ("launch" :: String) + ] ++ + [ "entryFile" .= (lcProjectRoot ef) | Just ef <- [lcEntryFile] ] ++ + [ "entryPoint" .= ep | Just ep <- [lcEntryPoint] ] ++ + [ "entryArgs" .= lcEntryArgs ] ++ + [ "extraGhcArgs" .= lcExtraGhcArgs ] ++ + [ "internalInterpreter" .= b | Just b <- [lcInternalInterpreter] ] + +-- | Set breakpoints in a particular source file of a project at the given +-- lines. +setLineBreakpoints :: FilePath -- ^ project root + -> FilePath -- ^ entry file (relative to project root) + -> [Int] + -> ResponseCont Value a -> TestDAP a +setLineBreakpoints projectRoot entryFile lines_ = + setBreakpointsIn projectRoot entryFile + [ defaultSourceBreakpoint { sourceBreakpointLine = l } | l <- lines_ ] + +-- | Set breakpoints (with arbitrary 'SourceBreakpoint's) in a particular +-- source file of a project. +setBreakpointsIn :: FilePath -- ^ project root + -> FilePath -- ^ source file (relative to project root) + -> [SourceBreakpoint] + -> ResponseCont Value a -> TestDAP a +setBreakpointsIn projectRoot entryFile bps = + setBreakpointsRequest DAP.SetBreakpointsArguments + { DAP.setBreakpointsArgumentsSource = DAP.defaultSource + { DAP.sourceName = Just (T.pack (takeFileName entryFile)) + , DAP.sourcePath = Just (T.pack (projectRoot entryFile)) + } + , DAP.setBreakpointsArgumentsBreakpoints = Just bps + , DAP.setBreakpointsArgumentsLines = Just [sourceBreakpointLine bp | bp <- bps] + , DAP.setBreakpointsArgumentsSourceModified = Just False + } + +-- | Launch, configure breakpoint, hit breakpoint. +hitBreakpointWith :: LaunchConfig -> Int -> TestDAP () +hitBreakpointWith cfg@LaunchConfig{..} line = do + entryFile <- maybe (fail "hitBreakpointWith: missing entryFile") pure lcEntryFile + hitBreakpointIn cfg entryFile line + +-- | Launch, configure a breakpoint in the given source file (relative to +-- the project root) at the given line, then wait for it to be hit. +hitBreakpointIn :: LaunchConfig -> FilePath -> Int -> TestDAP () +hitBreakpointIn cfg@LaunchConfig{..} bpFile line = do + _ <- sync $ launchWith cfg + waitFiltering_ EventTy "initialized" + _ <- sync $ setLineBreakpoints lcProjectRoot bpFile [line] + _ <- sync configurationDone + _ <- assertStoppedLocation DAP.StoppedEventReasonBreakpoint line + return () + +-------------------------------------------------------------------------------- +-- ** Variable inspection +-------------------------------------------------------------------------------- +data VarsView = VarsView + { varsViewDesc :: String + , varsViewVars :: M.Map T.Text [Variable] } + +mkVarsView :: String -> [Variable] -> VarsView +mkVarsView ctxDesc vs = VarsView + { varsViewDesc = ctxDesc + , varsViewVars = M.fromListWith (++) [(variableName v, [v]) | v <- vs] } + +-- | Get variable by name +(%) :: VarsView -> String -> Variable +(%) vv n = case vv %% n of + [v] -> v + what -> error $ "Unexpected *many* variables by name " ++ show n ++ ": " ++ show what + +-- | Get variables by name (there may be more than one with the same name; e.g. consider punning) +(%%) :: VarsView -> String -> [Variable] +(%%) VarsView{..} n + | Just vs <- M.lookup (T.pack n) varsViewVars = vs + | otherwise = error $ + "Variable " ++ show n ++ " not found in " ++ varsViewDesc ++ ": " ++ show (M.keys varsViewVars) +-------------------------------------------------------------------------------- +-- | Fetch all variables from the scope with the given name in the top-most +-- frame of the first thread. +fetchScopeVars :: T.Text -> TestDAP VarsView +fetchScopeVars scopeName_ = do + Response{responseBody=Just ThreadsResponse{threads=t:_}} <- sync threadsRequest + Response{responseBody=Just StackTraceResponse{stackFrames=fr:_}} <- sync $ stackTraceRequest $ + StackTraceArguments + { DAP.stackTraceArgumentsThreadId = threadId t + , DAP.stackTraceArgumentsStartFrame = Nothing + , DAP.stackTraceArgumentsLevels = Nothing + , DAP.stackTraceArgumentsFormat = Nothing + } + Response{responseBody=Just ScopesResponse{scopes=scs}} <- sync $ scopesRequest $ + ScopesArguments { DAP.scopesArgumentsFrameId = stackFrameId fr } + case List.find ((== scopeName_) . scopeName) scs of + Nothing -> liftIO $ assertFailure $ + "fetchScopeVars: scope " ++ show scopeName_ + ++ " not found (" ++ show (map scopeName scs) ++ ")" + Just sc -> do + vs <- fetchChildren (scopeVariablesReference sc) + pure $ mkVarsView ("scope " ++ show scopeName_) vs + +fetchLocalVars :: TestDAP VarsView +fetchLocalVars = fetchScopeVars "Locals" + +fetchModuleVars :: TestDAP VarsView +fetchModuleVars = fetchScopeVars "Module" + +-- | Get the children of a variable by its variablesReference. +fetchChildren :: Int -> TestDAP [Variable] +fetchChildren ref = do + Response{responseBody=Just (VariablesResponse vs)} <- sync $ variablesRequest $ + VariablesArguments + { DAP.variablesArgumentsVariablesReference = ref + , DAP.variablesArgumentsFilter = Nothing + , DAP.variablesArgumentsStart = Nothing + , DAP.variablesArgumentsCount = Nothing + , DAP.variablesArgumentsFormat = Nothing + } + return vs + +-- | Force a lazy variable by sending a 'variables' request for its reference +-- and returning the first child. +forceLazy :: HasCallStack => Variable -> TestDAP Variable +forceLazy v = do + liftIO $ do + assertEqual ("Variable " ++ show (variableName v) ++ " should be lazy") + (Just True) (variablePresentationHintLazy =<< variablePresentationHint v) + assertEqual ("Variable " ++ show (variableName v) ++ " should be \"_\" because it is lazy") "_" (variableValue v) + assertBool ("Variable " ++ show (variableName v) ++ " should be expandable (because it is a lazy var)") $ + variableVariablesReference v /= 0 -- if it is expandable we get a reference to use to expand here + + -- Force the lazy variable by using its reference + vs <- fetchChildren (variableVariablesReference v) + case vs of + (v':_) -> pure v' + [] -> liftIO $ assertFailure $ "forceLazy: no children for forced variable " ++ show (variableName v) + +-- | Expand a structured variable. +expandVar :: HasCallStack => Variable -> TestDAP VarsView +expandVar v = do + liftIO $ + assertBool ("Variable " ++ show (variableName v) ++ " should be expandable (it should have structure)") $ + variableVariablesReference v /= 0 + vs <- fetchChildren (variableVariablesReference v) + pure $ mkVarsView ("children of " ++ T.unpack (variableName v)) vs + +-- | Assert that a variable has a given String value. +assertIsString :: HasCallStack => Variable -> T.Text -> TestDAP () +assertIsString v expected = liftIO $ do + assertEqual ("Variable " ++ show (variableName v) ++ " should be a String") + (Just "String") (variableType v) + assertEqual ("Variable " ++ show (variableName v) ++ " should be " ++ show expected) + expected (variableValue v) + assertEqual ("Variable " ++ show (variableName v) ++ " should not be expandable (because it is a String)") + 0 (variableVariablesReference v) + +-- | Assert the value of some variable. +-- e.g. @var \@==? "\"hello\""@ +(@==?) :: HasCallStack => Variable -> T.Text -> TestDAP () +(@==?) v expected = liftIO $ assertEqual (T.unpack (variableValue v) ++ " @==? " ++ T.unpack expected) expected (variableValue v) + +-------------------------------------------------------------------------------- +-- ** Exception info & other requests +-------------------------------------------------------------------------------- + +exceptionInfo :: Int -> TestDAP ExceptionInfoResponse +exceptionInfo tid = do + Response{responseBody=Just r} <- sync $ exceptionInfoRequest $ + ExceptionInfoArguments { DAP.exceptionInfoArgumentsThreadId = tid } + return r + +setBreakOnException :: TestDAP () +setBreakOnException = do + _ <- sync $ setExceptionBreakpointsRequest @_ @Value + SetExceptionBreakpointsArguments + { DAP.setExceptionBreakpointsArgumentsFilters = ["break-on-exception"] + , DAP.setExceptionBreakpointsArgumentsFilterOptions = Nothing + , DAP.setExceptionBreakpointsArgumentsExceptionOptions = Nothing + } + pure () + +continueThread :: Int -> TestDAP () +continueThread tid = do + _ <- sync $ continueRequest @_ @Value + ContinueArguments + { DAP.continueArgumentsThreadId = tid + , DAP.continueArgumentsSingleThread = False + } + pure () + +evaluate :: T.Text -> TestDAP EvaluateResponse +evaluate expr = do + Response{responseBody=Just r} <- sync $ evaluateRequest $ + EvaluateArguments + { DAP.evaluateArgumentsExpression = expr + , DAP.evaluateArgumentsFrameId = Nothing + , DAP.evaluateArgumentsContext = Nothing + , DAP.evaluateArgumentsFormat = Nothing + } + return r + +stepOut :: Int -> TestDAP () +stepOut tid = do + _ <- sync $ stepOutRequest @_ @Value + StepOutArguments + { DAP.stepOutArgumentsThreadId = tid + , DAP.stepOutArgumentsSingleThread = False + , DAP.stepOutArgumentsGranularity = Nothing + } + pure () + +-- | Wait for an "exited" event and assert the exit code. +waitForExitCode :: Int -> TestDAP () +waitForExitCode expected = do + Event{eventBody = Just ExitedEvent{exitedEventExitCode}} <- waitFiltering EventTy "exited" + liftIO $ assertEqual ("exit code should be " ++ show expected) expected exitedEventExitCode + +disconnect :: TestDAP () +disconnect = do + Response{responseSuccess} <- sync $ disconnectRequest @_ @Value $ Just + DisconnectArguments + { DAP.disconnectArgumentsRestart = False + , DAP.disconnectArgumentsTerminateDebuggee = True + , DAP.disconnectArgumentsSuspendDebuggee = False + } + liftIO $ assertBool "disconnect response should indicate success" responseSuccess + return () + +-------------------------------------------------------------------------------- +-- ** Convenience methods (based on vscode-debugadapter-node/testSupport) +-------------------------------------------------------------------------------- + +launch :: Value {-^ Launch args -} -> ResponseCont Value a -> TestDAP a +launch args = runContT $ + ContT initializeRequest + >>= liftIO . wait + >> ContT (launchRequest args) + +configurationSequence :: ResponseCont Value a -> TestDAP a +configurationSequence k = do + waitFiltering_ EventTy "initialized" + configurationDone k + +-- | Assert that a "stopped" event with the given reason is received, then +-- fetch the stack trace and assert the top frame is at the expected line. +assertStoppedLocation :: HasCallStack => DAP.StoppedEventReason -> Int -> TestDAP () +assertStoppedLocation reason expectedLine = do + Event{eventBody = Just StoppedEvent{stoppedEventReason, stoppedEventThreadId}} <- waitFiltering EventTy "stopped" + liftIO $ assertBool "Stopped reason matches expected reason" (stoppedEventReason == reason) + frames <- maybe (pure []) stackTrace stoppedEventThreadId + case frames of + (frame:_) -> liftIO $ assertEqual "stopped location: line mismatch" expectedLine (stackFrameLine frame) + [] -> liftIO $ assertFailure "assertStoppedLocation: no stack frames" + +-- | Assert that all *pending*(not yet taken from channel) accumulated output +-- events (until any other event is found) contain a certain string +assertOutput :: HasCallStack => T.Text -> TestDAP () +assertOutput expected = do + events <- waitAccumulating EventTy "output" + let outputs = map (outputEventOutput . fromMaybe (error "assertOutput:fromMaybe") . eventBody) events + liftIO $ + assertBool + ("assertOutput: expecting " ++ show expected ++ " but got " ++ show outputs) + (any (T.isInfixOf expected) outputs) + +assertFullOutput :: HasCallStack => T.Text -> TestDAP () +assertFullOutput expected = assertFullOutputWith (expected <> " \\in full_output") (T.isInfixOf expected) + +assertNotFullOutput :: HasCallStack => T.Text -> TestDAP () +assertNotFullOutput expected = assertFullOutputWith (expected <> " \\notin full_output") (not . T.isInfixOf expected) + +-- | Assert that the full output up until now matches any given string with the given function +assertFullOutputWith :: HasCallStack => T.Text -> (T.Text -> Bool) -> TestDAP () +assertFullOutputWith assertStr test = do + TestDAPClientContext{..} <- ask + fullOut <- liftIO $ readTVarIO clientFullOutput + liftIO $ assertBool + ("assertFullOutputWith: asserting '" ++ show assertStr ++ "' but got " ++ show fullOut) + (any test fullOut) + +-------------------------------------------------------------------------------- +-- * Waiting for messages +-------------------------------------------------------------------------------- + +data MsgType = EventTy | ResponseTy | ReverseRequestTy + deriving Show + +msgChan :: MsgType -> TestDAPClientContext -> TChan Value +msgChan ty TestDAPClientContext{..} = case ty of + EventTy -> clientEvents + ResponseTy -> clientResponses + ReverseRequestTy -> clientReverseRequests + +msgMatch :: MsgType -> String -> MessageMatch +msgMatch ty s = case ty of + EventTy -> eventMatch s + ResponseTy -> responseMatch s + ReverseRequestTy -> reverseRequestMatch s + +waitFiltering_ :: MsgType -> String -> TestDAP () +waitFiltering_ ty s = void $ waitFiltering @Value ty s + +-- | Drop messages of the given type until a message with the given +-- eventType/command is found. The matching message is returned. +-- FIXME: Timeouts on waiting, to avoid hanging forever in the testsuite!! +waitFiltering :: forall a. FromJSON a => MsgType -> String -> TestDAP a +waitFiltering ty s = do + ch <- asks (msgChan ty) + let mm = msgMatch ty s + let loop = do + v <- atomically $ readTChan ch -- block waiting for input + if messageMatchMatches mm v + then case fromJSON @a v of + Error e -> error $ "waitFiltering: Failed to parse message MATCHING " ++ s ++ ":" ++ show ty ++ " with error: " ++ e ++ "\nFull message was: " ++ show v + Success x -> return x + else loop + liftIO loop + +-- | Accumulate messages of the given type until a message with a +-- eventType/command different from the given one is found. -- -shouldReceive - :: Handle - -- ^ Handle to receive bytes from - -> [Pair] - -- ^ Subset of JSON values that should be present in the payload - -> IO () -shouldReceive h expected = do - case object expected of - Object ex -> - readPayload h >>= \case - Left e -> fail e - Right actual - | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure () - | otherwise -> encodePretty ex @=? encodePretty actual - _ -> fail "Invalid JSON" +-- The non-matching message is not consumed, nor returned, and will be kept in +-- the messages buffer. +waitAccumulating :: forall a. FromJSON a => MsgType -> String -> TestDAP [a] +waitAccumulating ty s = do + ch <- asks (msgChan ty) + let mm = msgMatch ty s + let loop acc = do + r <- atomically $ do + v <- readTChan ch + if messageMatchMatches mm v + then case fromJSON @a v of + Error e -> error $ "waitAccumulating: Failed to parse MATCHING message body with error: " ++ e ++ "\nFull message was: " ++ show v + Success x -> pure (Just x) + else Nothing <$ unGetTChan ch v + case r of + Nothing -> return (reverse acc) + Just v -> loop (v:acc) + liftIO $ loop [] + +-------------------------------------------------------------------------------- +-- * Protocol requests (based on vscode-debugadapter-node/testSupport) +-------------------------------------------------------------------------------- + +initializeRequest :: ResponseCont Value a -> TestDAP a +initializeRequest k = do + TestDAPClientContext{clientSupportsRunInTerminal} <- ask + customRequest "initialize" + (Just $ object $ + [ "adapterID" .= ("haskell-debugger" :: String) + , "clientID" .= ("mock-client" :: String) + , "clientName" .= ("Mock Client" :: String) + , "linesStartAt1" .= True + , "columnsStartAt1" .= True + , "locale" .= ("en" :: String) + , "pathFormat" .= ("path" :: String) + , "supportsRunInTerminalRequest" .= clientSupportsRunInTerminal + ]) k + +configurationDoneRequest :: Maybe Value -> ResponseCont Value a -> TestDAP a +configurationDoneRequest = customRequest "configurationDone" + +launchRequest, attachRequest, restartRequest, setBreakpointsRequest, + setFunctionBreakpointsRequest, setExceptionBreakpointsRequest, + setInstructionBreakpointsRequest, dataBreakpointInfoRequest, + setDataBreakpointsRequest, continueRequest, nextRequest, stepInRequest, + stepOutRequest, stepBackRequest, reverseContinueRequest, restartFrameRequest, + gotoRequest, pauseRequest, stackTraceRequest, scopesRequest, variablesRequest, + setVariableRequest, sourceRequest, modulesRequest, evaluateRequest, + disassembleRequest, stepInTargetsRequest, gotoTargetsRequest, completionsRequest, + exceptionInfoRequest, readMemoryRequest, writeMemoryRequest :: (ToJSON a, FromJSON b) => a -> ResponseCont b r -> TestDAP r + +launchRequest = requestWithArgs "launch" +attachRequest = requestWithArgs "attach" +restartRequest = requestWithArgs "restart" +setBreakpointsRequest = requestWithArgs "setBreakpoints" +setFunctionBreakpointsRequest = requestWithArgs "setFunctionBreakpoints" +setExceptionBreakpointsRequest = requestWithArgs "setExceptionBreakpoints" +setInstructionBreakpointsRequest = requestWithArgs "setInstructionBreakpoints" +dataBreakpointInfoRequest = requestWithArgs "dataBreakpointInfo" +setDataBreakpointsRequest = requestWithArgs "setDataBreakpoints" +continueRequest = requestWithArgs "continue" +nextRequest = requestWithArgs "next" +stepInRequest = requestWithArgs "stepIn" +stepOutRequest = requestWithArgs "stepOut" +stepBackRequest = requestWithArgs "stepBack" +reverseContinueRequest = requestWithArgs "reverseContinue" +restartFrameRequest = requestWithArgs "restartFrame" +gotoRequest = requestWithArgs "goto" +pauseRequest = requestWithArgs "pause" +stackTraceRequest = requestWithArgs "stackTrace" +scopesRequest = requestWithArgs "scopes" +variablesRequest = requestWithArgs "variables" +setVariableRequest = requestWithArgs "setVariable" +sourceRequest = requestWithArgs "source" +modulesRequest = requestWithArgs "modules" +evaluateRequest = requestWithArgs "evaluate" +disassembleRequest = requestWithArgs "disassemble" +stepInTargetsRequest = requestWithArgs "stepInTargets" +gotoTargetsRequest = requestWithArgs "gotoTargets" +completionsRequest = requestWithArgs "completions" +exceptionInfoRequest = requestWithArgs "exceptionInfo" +readMemoryRequest = requestWithArgs "readMemory" +writeMemoryRequest = requestWithArgs "writeMemory" + +terminateRequest, disconnectRequest :: (ToJSON a, FromJSON b) => Maybe a -> ResponseCont b r -> TestDAP r +terminateRequest = customRequest "terminate" +-- example: +-- object +-- [ "restart" .= False +-- , "terminateDebuggee" .= True +-- , "suspendDebuggee" .= False +-- ] +-- then... +-- wait "disconnected" +-- waitEventFiltering $ eventMatch "terminated" +disconnectRequest = customRequest "disconnect" + +threadsRequest :: FromJSON b => ResponseCont b r -> TestDAP r +threadsRequest = customRequest "threads" (Nothing :: Maybe ()) +-------------------------------------------------------------------------------- +requestWithArgs :: (ToJSON a, FromJSON b) => String -> a -> ResponseCont b r -> TestDAP r +requestWithArgs command args = customRequest command (Just args) + +-- example: respondWithBody revReqNum [ "shellProcessId" .= ... ] +respondWithBody :: Int -> String -> Value -> TestDAP () +respondWithBody seqNum command body = + reply seqNum $ + [ "type" .= ("response" :: String) + , "command" .= command + , "success" .= True + , "body" .= body + ] +-------------------------------------------------------------------------------- +customRequest :: (ToJSON a, FromJSON b) => String -> Maybe a -> ResponseCont b r -> TestDAP r +customRequest command args = do + send $ + [ "type" .= ("request" :: String) + , "command" .= command + ] ++ maybe [] (\v -> ["arguments" .= v]) args diff --git a/test/haskell/Test/DAP/Init.hs b/test/haskell/Test/DAP/Init.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP/Init.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module Test.DAP.Init where + +---------------------------------------------------------------------------- +import Data.Maybe +import Data.List (isInfixOf) +import Control.Exception hiding (handle) +import qualified Control.Exception as E +import Network.Run.TCP +import Network.Socket (Family(AF_INET), SockAddr(SockAddrInet, SockAddrInet6), SocketOption(ReuseAddr), SocketType(Stream), bind, close, defaultProtocol, getSocketName, setSocketOption, socket, socketToHandle, tupleToHostAddress) +import System.IO +import Control.Retry +import Data.IORef +import System.Environment (lookupEnv) +import System.FilePath ((), (<.>)) +import qualified System.Process as P +---------------------------------------------------------------------------- +import Test.DAP.Messages +import Control.Concurrent.STM +import Control.Concurrent.Async +import Control.Monad.Reader +import Control.Monad +import Data.Aeson.Types +import Test.Tasty.HUnit (assertFailure) +import DAP.Server (readPayload) +import qualified Control.Monad.Catch +import Test.Utils (withHermeticDir) +import DAP.Types (OutputEvent (..)) +import Test.DAP.Messages.Parser + +-------------------------------------------------------------------------------- +-- * Launch the DAP server process (what we're testing) +-------------------------------------------------------------------------------- + +data TestDAPServer = TestDAPServer + { testDAPServerPort :: Int + , testDAPServerCleanup :: IO () + , testDAPServerFlushOutput :: IO () + } + +-- | Launch an @hdb server@ for tests on a random local port and capture stdout. +-- Prefer withTestDAPServer because it will terminate the process at the end. +startTestDAPServer :: FilePath -> [String] -> IO TestDAPServer +startTestDAPServer testDir flags = do + testPort <- getAvailablePort + let nameTemplate= testDir ("server_port_" ++ show testPort) + let openHandle ext = do + h <- openFile (nameTemplate <.> ext) WriteMode + hSetBuffering h LineBuffering + pure h + hout <- openHandle "out" + herr <- openHandle "err" + (Just hin, Nothing, Nothing, p) + <- P.createProcess (P.proc "hdb" $ ["server"] ++ flags ++ ["--port", show testPort]) + { P.cwd = Just testDir + , P.std_out = P.UseHandle hout + , P.std_err = P.UseHandle herr + , P.std_in = P.CreatePipe + } + + pid <- fromMaybe 0 <$> P.getPid p + writeFile (nameTemplate <.> "pid") (show pid) + + let flushServerOutput = do + putStrLn "\n--- SERVER OUTPUT ---" + putStrLn $ "See: " ++ testDir + putStrLn $ "Might need: KEEP_TEMP_DIRS=True" + putStrLn "---------------------\n" + + pure TestDAPServer + { testDAPServerPort = testPort + , testDAPServerFlushOutput = flushServerOutput + , testDAPServerCleanup = do + P.cleanupProcess (Just hin, Just hout, Just herr, p) + + } + +-- | Prefer this to startTestDAPServer +withTestDAPServer :: FilePath -> [String] -> (FilePath -> TestDAPServer -> IO a) -> IO a +withTestDAPServer dir flags check' = do + keep_tmp_dirs <- maybe False read <$> lookupEnv "KEEP_TEMP_DIRS" + withHermeticDir keep_tmp_dirs dir $ \test_dir -> + bracket (startTestDAPServer test_dir flags) + testDAPServerCleanup + (check' test_dir) + +getAvailablePort :: IO Int +getAvailablePort = + bracket open close $ \sock -> do + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 (tupleToHostAddress (0, 0, 0, 0))) + getSocketName sock >>= \case + SockAddrInet port _ -> pure (fromIntegral port) + SockAddrInet6 port _ _ _ -> pure (fromIntegral port) + addr -> error $ "getAvailablePort: unexpected socket address " ++ show addr + where + open = socket AF_INET Stream defaultProtocol + +-------------------------------------------------------------------------------- +-- * Launch the client connecting to the server (the test driver) +-------------------------------------------------------------------------------- + +-- | Like 'withTestDAPServerClientWith' but default: +-- - @RunInTerminal = False@ +-- - @clientHandleNoSuccess = \_ _ -> pure Nothing@ (by default, success: false FAILS test) +withTestDAPServerClient :: TestDAPServer -> TestDAP a -> IO a +withTestDAPServerClient = withTestDAPServerClientWith False (\_ _ -> pure Nothing) + +--- | Connect a test client to a running 'TestDAPServer', with retry semantics +--- and server log flushing on failure. +withTestDAPServerClientWith :: Bool {-^ Announce support for runInTerminal? -} -> (String -> Value -> IO (Maybe Value)) + -> TestDAPServer -> TestDAP a -> IO a +withTestDAPServerClientWith clientSupportsRunInTerminal clientHandleNoSuccess server continue = do + runClient `E.onException` testDAPServerFlushOutput server + where + runClient = do + withNewClient (testDAPServerPort server) $ \clientHandle -> do + clientNextSeqRef <- newIORef 1 + clientReverseRequests <- newTChanIO + clientResponses <- newTChanIO + clientEvents <- newTChanIO + clientFullOutput <- newTVarIO [] + let ctx = TestDAPClientContext{..} + either id (\() -> error "handleServerTestDAP unexpectedly returned") <$> race + (runTestDAP continue ctx) + (runTestDAP handleServerTestDAP ctx) + +-- | Spawns a new mock client that connects to the mock server. +withNewClient :: forall a. Int -- ^ Port + -> (Handle -> IO a) + -> IO a +withNewClient port continue = do + recovering (constantDelay 50000 <> limitRetries 50) retry_handlers $ \_ -> + runTCPClient "127.0.0.1" (show port) $ \sock -> do + h <- socketToHandle sock ReadWriteMode + hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF } + continue h `finally` hClose h + where + retry_handlers = + skipAsyncExceptions ++ + [const $ Control.Monad.Catch.Handler $ \ (e :: IOException) -> return $ "Network.Socket.connect" `isInfixOf` show e] + +-------------------------------------------------------------------------------- +-- ** Handle server responses, events, and reverse requests +-------------------------------------------------------------------------------- + +-- | Forever: read messages from handle and write them either to clientNonEvents or clientEvents +handleServerTestDAP :: TestDAP () +handleServerTestDAP = do + TestDAPClientContext{..} <- ask + forever $ do + payload <- nextPayload + liftIO $ case parseMaybe parseType payload of + Just "event" -> do + let mtxt = fromJSON @(Event OutputEvent) payload + atomically $ do + writeTChan clientEvents payload + case mtxt of + Success (Event _ (Just txt)) -> modifyTVar' clientFullOutput (outputEventOutput txt:) + _ -> pure () + Just "response" -> + -- Fail immediately if the server reports failure, even if the test + -- is blocked waiting for some other specific message -- + -- unless the test has opted into handling failed responses itself. + case parseMaybe parseSuccess payload of + Just errMsg -> clientHandleNoSuccess errMsg payload >>= \case + Just v -> atomically $ writeTChan clientResponses v + Nothing -> assertFailure errMsg + Nothing -> atomically $ writeTChan clientResponses payload + Just "request" -> atomically $ do writeTChan clientReverseRequests payload + Just ty -> assertFailure $ "handleServerTestDAP: Unsupported message type: " ++ show ty + Nothing -> assertFailure $ "Received message without type: " ++ show payload + where + nextPayload = do + TestDAPClientContext{clientHandle = h} <- ask + payload <- liftIO $ readPayload h + case payload of + Left e -> fail e + Right actual -> pure actual + + parseType = withObject "message" $ \o -> do + typ <- o .: "type" + pure ((typ :: String)) + + -- Returns an error message when success is False, Nothing when success is True. + parseSuccess = withObject "response" $ \o -> do + success <- o .: "success" + if success + then fail "success" + else do + msg <- o .:? "message" .!= "DAP response had success: false (no message)" + pure (msg :: String) diff --git a/test/haskell/Test/DAP/Messages.hs b/test/haskell/Test/DAP/Messages.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP/Messages.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module Test.DAP.Messages where +---------------------------------------------------------------------------- +import Control.Concurrent.Async +import Control.Monad.IO.Class +import Data.Aeson +import Data.Aeson.Types +import Control.Monad.Reader +import qualified Data.ByteString as BS +import System.IO +import Data.IORef +---------------------------------------------------------------------------- +import DAP.Utils +import Control.Concurrent.STM +import qualified Data.Text as T +import Test.DAP.Messages.Parser +---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- +-- * Monad for DAP client context +---------------------------------------------------------------------------- + +data TestDAPClientContext = TestDAPClientContext + { clientHandle :: Handle + -- ^ Connection to server + , clientNextSeqRef :: IORef Int + -- ^ Counter for seq numbers + , clientResponses :: TChan Value + -- ^ Collect response messages sent by server + , clientEvents :: TChan Value + -- ^ Collect event messages sent by server + , clientReverseRequests :: TChan Value + -- ^ Collect reverse requests messages sent by server + , clientFullOutput :: TVar [T.Text] + -- ^ The full output is available here in reverse order (from most recent to oldest output strings). + -- + -- The output events are STILL available from the events channel (this + -- might be useful if you want to check a certain output event happens + -- after some other specific event like a stopped one, rather than just + -- overall). + -- + -- We keep this full text because it is often useful to query the full + -- output and not care about ordering. + , clientSupportsRunInTerminal :: Bool + -- ^ Run test with runInTerminal support? + , clientHandleNoSuccess :: String -> Value -> IO (Maybe Value) + -- ^ How to handle a response with success: false? If this function returns + -- @Just val@ something then execution will resume with the returned @val@ + -- rather than aborting. + } + +newtype TestDAP a = TestDAP { runTestDAP :: TestDAPClientContext -> IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFail, MonadReader TestDAPClientContext) via (ReaderT TestDAPClientContext IO) + +-------------------------------------------------------------------------------- +-- * Message primitives +-------------------------------------------------------------------------------- + +type AsyncCont b a = Async b -> TestDAP a +type ResponseCont b a = Async (Response b) -> TestDAP a + +-- | Run an action with an Async in the continuation synchronously by simply +-- waiting for the response. +sync :: (ResponseCont b (Response b) -> TestDAP (Response b)) -> TestDAP (Response b) +sync k = k (liftIO . wait) + +-- | Send message with next sequence number and expect a response (response +-- value is given as async in continuation) +send :: forall b r. FromJSON b => [Pair] -> ResponseCont b r -> TestDAP r +send message k = do + ctx@TestDAPClientContext{..} <- ask + seqNum <- liftIO $ atomicModifyIORef' clientNextSeqRef (\n -> (n + 1, n)) + liftIO $ do + BS.hPutStr clientHandle $ + encodeBaseProtocolMessage (object ("seq" .= seqNum : filter ((/= "seq") . fst) message)) + + withAsync (runTestDAP waitForResponse ctx) $ \v -> + runTestDAP (k $ (\r -> unwrap (fromJSON @(Response b) r) r) <$> v) ctx + where + unwrap (Error e) r = error ("send: Parsing 'Response' failed with " ++ show e ++ " for message: " ++ show r) + unwrap (Success x) _ = x + +-- | Reply to reverse request of given seq number +reply :: Int -> [Pair] -> TestDAP () +reply revReqSeqNum message = do + TestDAPClientContext{..} <- ask + liftIO $ do + BS.hPutStr clientHandle $ + encodeBaseProtocolMessage (object ("seq" .= (revReqSeqNum + 1) : filter ((/= "seq") . fst) message)) + +waitForResponse :: TestDAP Value +waitForResponse = do + TestDAPClientContext{..} <- ask + liftIO $ atomically $ readTChan clientResponses + +waitForReverseRequest :: TestDAP Value +waitForReverseRequest = do + TestDAPClientContext{..} <- ask + liftIO $ atomically $ readTChan clientReverseRequests + +waitForEvent :: TestDAP Value +waitForEvent = do + TestDAPClientContext{..} <- ask + liftIO $ atomically $ readTChan clientEvents + diff --git a/test/haskell/Test/DAP/Messages/Parser.hs b/test/haskell/Test/DAP/Messages/Parser.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP/Messages/Parser.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.DAP.Messages.Parser where + +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.KeyMap +import qualified Data.HashMap.Strict as H +import Test.DAP.Orphans () + +-------------------------------------------------------------------------------- +-- * MessageMatch +-------------------------------------------------------------------------------- + +data MessageMatch = MessageMatch + { messageMatchDescription :: String + , messageMatchMatches :: Value -> Bool + } + +subsetMatch :: [Pair] -> MessageMatch +subsetMatch expected = + MessageMatch ("subset: " ++ show (object expected)) $ \actual -> + case (object expected, actual) of + (Object ex, Object actualObj) -> + toHashMapText ex `H.isSubmapOf` toHashMapText actualObj + _ -> False + +responseMatch :: String -> MessageMatch +responseMatch cmd = + MessageMatch ("response(" ++ cmd ++ ")") $ \v -> + maybe False id $ parseMaybe (withObject "response" $ \o -> do + typ <- o .: "type" + responseCmd <- o .: "command" + success <- o .: "success" + pure ((typ :: String) == "response" && (responseCmd :: String) == cmd && (success :: Bool)) + ) v + +eventMatch :: String -> MessageMatch +eventMatch eventNameExpected = + MessageMatch ("event(" ++ eventNameExpected ++ ")") $ \v -> + maybe False id $ parseMaybe (withObject "event" $ \o -> do + typ <- o .: "type" + eventName <- o .: "event" + pure ((typ :: String) == "event" && (eventName :: String) == eventNameExpected) + ) v + +reverseRequestMatch :: String -> MessageMatch +reverseRequestMatch commandExpected = + MessageMatch ("reverseRequest(" ++ commandExpected ++ ")") $ \v -> + maybe False id $ parseMaybe (withObject "reverseRequest" $ \o -> do + typ <- o .: "type" + command <- o .: "command" + pure ((typ :: String) == "request" && (command :: String) == commandExpected) + ) v + +-------------------------------------------------------------------------------- +-- * Message parsers +-------------------------------------------------------------------------------- + +data Response a = Response + { responseSuccess :: Bool + , responseBody :: Maybe a } + +data Event a = Event + { eventEvent :: String + , eventBody :: Maybe a } + +instance FromJSON a => FromJSON (Response a) where + parseJSON = withObject "parsing from .body" $ \o -> do + body <- o .:? "body" + success <- o .: "success" + pure $ Response success body + +instance FromJSON a => FromJSON (Event a) where + parseJSON = withObject "parsing from .body" $ \o -> do + body <- o .:? "body" + event <- o .: "event" + pure $ Event event body diff --git a/test/haskell/Test/DAP/Orphans.hs b/test/haskell/Test/DAP/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP/Orphans.hs @@ -0,0 +1,237 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Test.DAP.Orphans () where + +import Data.Aeson +import qualified Data.Text as T +import DAP.Utils (genericParseJSONWithModifier, genericToJSONWithModifier) +import DAP + +-------------------------------------------------------------------------------- +-- * FromJSON instances for response body types (client parses server responses) +-------------------------------------------------------------------------------- + +instance FromJSON Breakpoint where + parseJSON = genericParseJSONWithModifier + +instance FromJSON PresentationHint where + parseJSON = genericParseJSONWithModifier + +instance FromJSON StackFrame where + parseJSON = genericParseJSONWithModifier + +instance FromJSON Scope where + parseJSON = genericParseJSONWithModifier + +instance FromJSON ScopePresentationHint where + parseJSON = withText "ScopePresentationHint" $ \t -> pure $ case t of + "arguments" -> ScopePresentationHintArguments + "locals" -> ScopePresentationHintLocals + "registers" -> ScopePresentationHintRegisters + other -> ScopePresentationHint other + +instance FromJSON StoppedEventReason where + parseJSON = withText "StoppedEventReason" $ \t -> case t of + "step" -> pure StoppedEventReasonStep + "breakpoint" -> pure StoppedEventReasonBreakpoint + "exception" -> pure StoppedEventReasonException + "pause" -> pure StoppedEventReasonPause + "entry" -> pure StoppedEventReasonEntry + "goto" -> pure StoppedEventReasonGoto + "function breakpoint" -> pure StoppedEventReasonFunctionBreakpoint + "data breakpoint" -> pure StoppedEventReasonDataBreakpoint + "instruction breakpoint" -> pure StoppedEventReasonInstructionBreakpoint + other -> fail $ "Unknown StoppedEventReason: " ++ show other + +instance FromJSON StoppedEvent where + parseJSON = genericParseJSONWithModifier + +instance FromJSON OutputEventCategory where + parseJSON = withText "OutputEventCategory" $ \t -> pure $ case t of + "console" -> OutputEventCategoryConsole + "important" -> OutputEventCategoryImportant + "stdout" -> OutputEventCategoryStdout + "stderr" -> OutputEventCategoryStderr + "telemetry" -> OutputEventCategoryTelemetry + other -> OutputEventCategory other + +instance FromJSON ThreadsResponse where + parseJSON = withObject "fromJSON:ThreadsResponse" $ \o -> do + ts <- o .: "threads" + pure $ ThreadsResponse ts + +instance FromJSON StackTraceResponse where + parseJSON = withObject "fromJSON:StackTraceResponse" $ \o -> do + fs <- o .: "stackFrames" + tot <- o .:? "totalFrames" + pure $ StackTraceResponse fs tot + +instance FromJSON ScopesResponse where + parseJSON = withObject "fromJSON:ScopesResponse" $ \o -> do + scs <- o .: "scopes" + pure $ ScopesResponse scs + +instance FromJSON EventGroup where + parseJSON = genericParseJSONWithModifier + +instance FromJSON OutputEvent where + parseJSON = genericParseJSONWithModifier + +instance FromJSON Variable where + parseJSON = genericParseJSONWithModifier + +instance FromJSON VariablePresentationHint where + parseJSON = genericParseJSONWithModifier + +instance FromJSON PresentationHintKind where + parseJSON = withText "PresentationHintKind" $ \t -> pure $ case t of + "property" -> PresentationHintKindProperty + "method" -> PresentationHintKindMethod + "class" -> PresentationHintKindClass + "data" -> PresentationHintKindData + "event" -> PresentationHintKindEvent + "baseClass" -> PresentationHintKindBaseClass + "innerClass" -> PresentationHintKindInnerClass + "interface" -> PresentationHintKindInterface + "mostDerivedClass" -> PresentationHintKindMostDerivedClass + "virtual" -> PresentationHintKindVirtual + "dataBreakpoint" -> PresentationHintKindDataBreakpoint + other -> PresentationHintKind other + +instance FromJSON PresentationHintVisibility where + parseJSON = withText "PresentationHintVisibility" $ \t -> pure $ case t of + "public" -> PresentationHintVisibilityPublic + "private" -> PresentationHintVisibilityPrivate + "protected" -> PresentationHintVisibilityProtected + "internal" -> PresentationHintVisibilityInternal + "final" -> PresentationHintVisibilityFinal + other -> PresentationHintVisibility (T.unpack other) + +instance FromJSON PresentationHintAttributes where + parseJSON = withText "PresentationHintAttributes" $ \t -> pure $ case t of + "static" -> PresentationHintAttributesStatic + "constant" -> PresentationHintAttributesConstant + "readOnly" -> PresentationHintAttributesReadOnly + "rawText" -> PresentationHintAttributesRawText + "hasObjectId" -> PresentationHintAttributesHasObjectId + "canHaveObjectId" -> PresentationHintAttributesCanHaveObjectId + "hasSideEffects" -> PresentationHintAttributesHasSideEffects + "hasDataBreakpoint" -> PresentationHintAttributesHasDataBreakpoint + other -> PresentationHintAttributes (T.unpack other) + +instance FromJSON VariablesResponse where + parseJSON = withObject "fromJSON:VariablesResponse" $ \o -> do + vs <- o .: "variables" + pure $ VariablesResponse vs + +instance FromJSON EvaluateResponse where + parseJSON = genericParseJSONWithModifier + +instance FromJSON ExceptionInfoResponse where + -- NB: we parse 'breakMode' manually because the stock 'genericParseJSON' + -- of the 'ExceptionBreakMode' sum type (as defined in DAP.Types) does not + -- correctly map the JSON tag "never"/"always"/"unhandled"/"userUnhandled" + -- to the corresponding constructors when the constructor name lacks a + -- common prefix. + parseJSON = withObject "ExceptionInfoResponse" $ \o -> do + exceptionId <- o .: "exceptionId" + description <- o .:? "description" + breakModeTxt <- o .: "breakMode" + bm <- case (breakModeTxt :: T.Text) of + "never" -> pure Never + "always" -> pure Always + "unhandled" -> pure Unhandled + "userUnhandled" -> pure UserUnhandled + other -> fail $ "Unknown ExceptionBreakMode: " ++ show other + details <- o .:? "details" + pure ExceptionInfoResponse + { exceptionInfoResponseExceptionId = exceptionId + , exceptionInfoResponseDescription = description + , exceptionInfoResponseBreakMode = bm + , exceptionInfoResponseDetails = details + } + +instance FromJSON ExceptionDetails where + parseJSON = genericParseJSONWithModifier + +instance FromJSON ExitedEvent where + parseJSON = genericParseJSONWithModifier + +-------------------------------------------------------------------------------- +-- * ToJSON instances for request argument types (client sends requests) +-------------------------------------------------------------------------------- + +instance ToJSON PathFormat where + toJSON Path = "path" + toJSON URI = "uri" + toJSON (PathFormat t) = toJSON t + +instance ToJSON InitializeRequestArguments where + toJSON = genericToJSON defaultOptions { omitNothingFields = True } + +instance ToJSON SetBreakpointsArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON SourceBreakpoint where + toJSON = genericToJSONWithModifier + +instance ToJSON SteppingGranularity where + toJSON = genericToJSONWithModifier + +instance ToJSON NextArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON StackFrameFormat where + toJSON = genericToJSONWithModifier + +instance ToJSON StackTraceArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON ScopesArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON ValueFormat where + toJSON = genericToJSONWithModifier + +instance ToJSON DisconnectArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON VariablesArguments where + toJSON VariablesArguments{..} = object $ + [ "variablesReference" .= variablesArgumentsVariablesReference + ] ++ + [ "start" .= v | Just v <- [variablesArgumentsStart] ] ++ + [ "count" .= v | Just v <- [variablesArgumentsCount] ] ++ + [ "format" .= v | Just v <- [variablesArgumentsFormat] ] + +instance ToJSON StepOutArguments where + toJSON StepOutArguments{..} = object $ + [ "threadId" .= stepOutArgumentsThreadId + , "singleThread" .= stepOutArgumentsSingleThread + ] ++ + [ "granularity" .= g | Just g <- [stepOutArgumentsGranularity] ] + +instance ToJSON ContinueArguments where + toJSON ContinueArguments{..} = object + [ "threadId" .= continueArgumentsThreadId + , "singleThread" .= continueArgumentsSingleThread + ] + +instance ToJSON EvaluateArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON SetExceptionBreakpointsArguments where + toJSON = genericToJSONWithModifier + +instance ToJSON ExceptionFilterOptions where + toJSON = genericToJSONWithModifier + +instance ToJSON ExceptionOptions where + toJSON = genericToJSONWithModifier + +instance ToJSON ExceptionPathSegment where + toJSON = genericToJSONWithModifier + +instance ToJSON ExceptionInfoArguments where + toJSON = genericToJSONWithModifier diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs deleted file mode 100644 --- a/test/haskell/Test/DAP/RunInTerminal.hs +++ /dev/null @@ -1,298 +0,0 @@ --- | 'runInTerminal' tests -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} -module Test.DAP.RunInTerminal (runInTerminalTests) where - -import System.Exit -import Control.Exception -import Control.Monad -import Control.Concurrent -import DAP.Types -import DAP.Utils -import Data.Aeson -import Data.IORef -import Data.List (isInfixOf) -import System.FilePath -import System.IO -import System.Random -import Test.DAP -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.ExpectedFailure -import Test.Utils -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LB8 -import qualified Data.HashMap.Strict as H -import qualified Data.Text as T -import qualified System.Process as P - -runInTerminalTests = - testGroup "DAP.RunInTerminal" - [ -#ifdef mingw32_HOST_OS - ignoreTestBecause "Needs to be fixed for Windows (#199)" $ -#endif - testGroup "runInTerminal: proxy forwards stdin correctly" - [ testCase "(default)" (runInTerminal1 "") - , testCase "(--internal-interpreter)" (runInTerminal1 "--internal-interpreter") - ] - ] - -rit_keep_tmp_dirs :: Bool -rit_keep_tmp_dirs = False - -runInTerminal1 flags = do - withHermeticDir rit_keep_tmp_dirs "test/unit/T44" $ \test_dir -> do - - -- Come up with a random port - testPort <- randomRIO (49152, 65534) :: IO Int - - -- Launch server process - (Just hin, Just hout, _, p) - <- P.createProcess (P.shell $ "hdb server " ++ flags ++ " --port " ++ show testPort) - {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe} - - serverOutputRef <- newIORef [] - - -- Fork thread to print out output of server process - -- This is surprisingly needed, otherwise the server process - -- will be broken, perhaps because it blocks trying to write to stdout/stderr if the buffer is full? - forkIO $ flip catch (\(e :: IOException) -> print ("server process forwarding", e)) $ do - hSetBuffering hout LineBuffering - let loop = do - eof <- hIsEOF hout - if eof - then return () - else do - _l <- hGetLine hout - modifyIORef' serverOutputRef (_l :) - loop - loop - - let flushServerOutput = do - putStrLn "\n--- SERVER OUTPUT ---" - readIORef serverOutputRef >>= mapM_ putStrLn . reverse - putStrLn "---------------------\n" - - retryVar <- newIORef True - -- Connect to the DAP server - flip onException flushServerOutput $ withNewClient testPort retryVar $ \handle -> do - -- As soon as we get a connection, stop retrying - writeIORef retryVar False - - -- Initialize - sendDAPRequest handle CommandInitialize InitializeRequestArguments - { adapterID = "haskell-debugger" - , clientID = Just "mock-client" - , clientName = Just "Mock Client" - , columnsStartAt1 = Just True - , linesStartAt1 = Just True - , locale = Just "en" - , pathFormat = Just Path - , supportsArgsCanBeInterpretedByShell = Nothing - , supportsInvalidatedEvent = Nothing - , supportsMemoryEvent = Nothing - , supportsMemoryReferences = Nothing - , supportsProgressReporting = Nothing - , supportsRunInTerminalRequest = Just True - , supportsStartDebuggingRequest = Nothing - , supportsVariablePaging = Nothing - , supportsVariableType = Nothing - } - - -- Recv initalize response - _ <- shouldReceive handle [] - - -- Send launch request - send handle - [ "command" .= ("launch" :: String) - , "seq" .= (2 :: Int) - , "type" .= ("request" :: String) - , "arguments".= object - [ "entryFile" .= (test_dir "Main.hs" :: String) - , "entryPoint" .= ("main" :: String) - , "projectRoot" .= (test_dir :: String) - , "extraGhcArgs" .= ([] :: [String]) - , "entryArgs" .= ([] :: [String]) - , "request" .= ("launch" :: String) - ] - ] - - -- Receive output events - forM_ [1..9] $ \_ -> - shouldReceive handle - ["type" .= ("event" :: String), "event" .= ("output" :: String)] - _ <- shouldReceive handle - [ "command" .= ("launch" :: String) - , "success" .= True] - _ <- shouldReceive handle - [ "event" .= ("initialized" :: String) - , "type" .= ("event" :: String) - ] - - -- Receive a runInTerminal request!! - r@RunInTerminalRequestArguments{} <- recvDAPResponse handle - (Just rit_in, Just rit_out, _, rit_p) - <- P.createProcess - (P.shell $ T.unpack $ - "/usr/bin/env " <> addRITEnv r.runInTerminalRequestArgumentsEnv <> " " <> T.unwords (r.runInTerminalRequestArgumentsArgs)) - {P.cwd = Just test_dir, P.std_in = P.CreatePipe, P.std_out = P.CreatePipe} - - -- Send a breakpoint request - sendDAPRequest handle CommandSetBreakpoints - SetBreakpointsArguments - { setBreakpointsArgumentsSource = Source - { sourceName = Just "Main.hs" - , sourcePath = Just $ T.pack $ test_dir "Main.hs" - , sourceSourceReference = Nothing - , sourcePresentationHint = Nothing - , sourceOrigin = Nothing - , sourceAdapterData = Nothing - , sourceChecksums = Nothing - , sourceSources = Nothing - } - , setBreakpointsArgumentsBreakpoints = Just [SourceBreakpoint {sourceBreakpointLine = 6, sourceBreakpointColumn = Nothing, sourceBreakpointCondition = Nothing, sourceBreakpointHitCondition = Nothing, sourceBreakpointLogMessage = Nothing}] - , setBreakpointsArgumentsLines = Just [6] - , setBreakpointsArgumentsSourceModified = Just False - } - - _ <- shouldReceive handle - [ "command" .= ("setBreakpoints" :: String) - , "success" .= True - , "type" .= ("response" :: String) - ] - - -- Send runInTerminal response - Just rit_pid <- P.getPid rit_p - send handle - [ "command" .= ("runInTerminal" :: String) - , "seq" .= (6 :: Int) - , "type" .= ("response" :: String) - , "success" .= True - , "body" .= object - [ "shellProcessId" .= (fromIntegral rit_pid :: Int) - ] - ] - - send handle - [ "seq" .= (1 :: Int) - , "type" .= ("request" :: String) - , "command" .= CommandConfigurationDone - ] - - _ <- shouldReceive handle - [ "command" .= ("configurationDone" :: String) - , "success" .= True - , "type" .= ("response" :: String) - ] - - -- The program should start running now, and hit the breakpoint. - -- It will also print "Hello". Since the order is not important, we just - -- match on the type == event and ignore if it's "stopped" or "output" - _ <- shouldReceive handle - [ "type" .= ("event" :: String) ] - _ <- shouldReceive handle - [ "type" .= ("event" :: String) ] - - -- Continue from "getLine" which will block waiting for input - goToNextLine handle - - let secret_in = "SOMETHING_SECRET" - - -- Time to write to the stdin of the rit process - hSetBuffering rit_in LineBuffering - hPutStrLn rit_in secret_in - - -- Only after writing should we receive the next "stopped" event - _ <- shouldReceive handle - ["type" .= ("event" :: String), "event" .= ("stopped" :: String)] - - -- To next line, which should be the "putStrLn" after the "getLine" - goToNextLine handle - -- It's both stopped and we receive the SOMETHING_SECRET printed out. Order not important. - _ <- shouldReceive handle - ["type" .= ("event" :: String)] - _ <- shouldReceive handle - ["type" .= ("event" :: String)] - - -- The contents of the rit_output should contain "hello" plus printing of what we wrote - out <- LBS.hGetContents rit_out - let out_str = LB8.unpack out - assertBool ("Expected output to contain 'hello', got: " ++ show out_str) - ("hello" `isInfixOf` out_str) - assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ show out_str) - (secret_in `isInfixOf` out_str) - - -- Send disconnect - sendDAPRequest handle CommandDisconnect (DisconnectArguments {disconnectArgumentsRestart = False, disconnectArgumentsTerminateDebuggee = True, disconnectArgumentsSuspendDebuggee = False}) - _ <- shouldReceive handle - [ "command" .= ("disconnect" :: String) - , "success" .= True - , "type" .= ("response" :: String) - ] - _ <- shouldReceive handle - [ "event" .= ("terminated" :: String) - , "type" .= ("event" :: String) - ] - -- Kill the processes if they're still running - P.terminateProcess rit_p - P.terminateProcess p - - where - goToNextLine handle = do - _ <- sendDAPRequest handle CommandNext (Just (NextArguments {nextArgumentsThreadId = 0, nextArgumentsSingleThread = Nothing, nextArgumentsGranularity = Nothing})) - _ <- shouldReceive handle - [ "command" .= ("next" :: String) - , "success" .= True - , "type" .= ("response" :: String) - ] - return () - - addRITEnv :: Maybe (H.HashMap T.Text T.Text) -> T.Text - addRITEnv env = - case env of - Nothing -> "" - Just env -> T.unwords [k{-todo: escape-} <> "=" <> v | (k,v) <- H.toList env] --------------------------------------------------------------------------------- -instance ToJSON InitializeRequestArguments where - toJSON InitializeRequestArguments{..} = object - [ "adapterID" .= adapterID - , "clientID" .= clientID - , "clientName" .= clientName - , "columnsStartAt1" .= columnsStartAt1 - , "linesStartAt1" .= linesStartAt1 - , "locale" .= locale - , "pathFormat" .= pathFormat - , "supportsArgsCanBeInterpretedByShell" .= supportsArgsCanBeInterpretedByShell - , "supportsInvalidatedEvent" .= supportsInvalidatedEvent - , "supportsMemoryEvent" .= supportsMemoryEvent - , "supportsMemoryReferences" .= supportsMemoryReferences - , "supportsProgressReporting" .= supportsProgressReporting - , "supportsRunInTerminalRequest" .= supportsRunInTerminalRequest - , "supportsStartDebuggingRequest" .= supportsStartDebuggingRequest - , "supportsVariablePaging" .= supportsVariablePaging - , "supportsVariableType" .= supportsVariableType - ] -instance ToJSON PathFormat where - toJSON Path = String "path" - toJSON URI = String "uri" - toJSON (PathFormat x) = String x -instance ToJSON SetBreakpointsArguments where - toJSON = genericToJSONWithModifier -instance ToJSON NextArguments where - toJSON = genericToJSONWithModifier -instance ToJSON DisconnectArguments where - toJSON = genericToJSONWithModifier -instance ToJSON SourceBreakpoint where - toJSON = genericToJSONWithModifier -instance ToJSON SteppingGranularity where - toJSON = genericToJSONWithModifier -instance FromJSON bps => FromJSON (Breakpoints bps) where - parseJSON = withObject "bkrps" $ \o -> - Breakpoints <$> o .: "breakpoints" -instance FromJSON Breakpoint where - parseJSON = genericParseJSONWithModifier - diff --git a/test/haskell/Test/Integration/Basic.hs b/test/haskell/Test/Integration/Basic.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Basic.hs @@ -0,0 +1,91 @@ +-- | Basic launch/run tests ported from the old NodeJS integration testsuite. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Test.Integration.Basic (basicTests) where + +import Control.Monad.Reader +import Test.DAP +import Test.DAP.Messages.Parser +import Test.Tasty +import Test.Tasty.HUnit +import qualified DAP + +basicTests :: TestTree +basicTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Basic" + [ testGroup "Most basic functionality" + [ basicForConfig "Vanilla config (no package)" "test/integration/simple" "Main.hs" + , basicForConfig "Cabal config" "test/integration/cabal1" "app/Main.hs" + , testGroup "Other basic tests" + [ testCase "report error on missing entryFile" reportMissingEntryFile + , testCase "minimal configuration with just entryFile" minimalConfig + , testCase "accepts internalInterpreter launch option" internalInterpreterOption + ] + ] + ] + +basicForConfig :: TestName -> FilePath -> FilePath -> TestTree +basicForConfig name projectRoot entryFile = + testGroup name + [ testSetup "should run program to the end" $ \cfg -> do + runToEnd cfg + , testSetup "should stop on a breakpoint" $ \cfg -> do + hitBreakpointWith cfg 6 + disconnect + , testSetup "should stop on an exception" $ \cfg -> do + _ <- sync $ launchWith cfg + waitFiltering_ EventTy "initialized" + setBreakOnException + _ <- sync configurationDone + assertStoppedLocation DAP.StoppedEventReasonException 66 -- FIXME WHY IS THIS 66? in the NodeJS testsuite we ignored the line. + disconnect + ] + where + testSetup s k = testCase s $ + withTestDAPServer projectRoot [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = (mkLaunchConfig test_dir entryFile) { lcEntryArgs = ["some", "args"] } + k cfg + +reportMissingEntryFile :: Assertion +reportMissingEntryFile = + withTestDAPServer "test/integration/T71" [] $ \test_dir server -> + withTestDAPServerClientWith False (\msg val -> do + assertBool "test should fail with missing key" + (msg == "Missing \"entryFile\" key in debugger configuration") + pure (Just val) -- continue with success=False... + ) server $ do + let cfg = (mkLaunchConfig test_dir "Main.hs") { lcEntryFile = Nothing } + Response{responseSuccess} <- sync $ launchWith cfg + liftIO $ assertBool "Expected test to fail with no entry file, but got success: true" + (not responseSuccess) + + +minimalConfig :: Assertion +minimalConfig = + withTestDAPServer "test/integration/T71" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = LaunchConfig + { lcProjectRoot = test_dir + , lcEntryFile = Just "Main.hs" + , lcEntryPoint = Nothing + , lcEntryArgs = [] + , lcExtraGhcArgs = [] + , lcInternalInterpreter = Nothing + } + hitBreakpointWith cfg 2 + disconnect + +internalInterpreterOption :: Assertion +internalInterpreterOption = + withTestDAPServer "test/integration/simple" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = (mkLaunchConfig test_dir "Main.hs") + { lcInternalInterpreter = Just True } -- TODO: Automatically run all tests with internal interpreter too? + hitBreakpointWith cfg 6 + disconnect diff --git a/test/haskell/Test/Integration/Conditional.hs b/test/haskell/Test/Integration/Conditional.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Conditional.hs @@ -0,0 +1,76 @@ +-- | Conditional breakpoint tests (issue #111) ported from the NodeJS testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.Conditional (conditionalTests) where + +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import qualified DAP +import DAP (SourceBreakpoint(..), defaultSourceBreakpoint) + +conditionalTests :: TestTree +conditionalTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Conditional" + [ testCase "Conditional expression breakpoints" conditionalExpr + , testCase "Hit count breakpoints" hitCount + ] + +conditionalExpr :: Assertion +conditionalExpr = + testWith False + defaultSourceBreakpoint + { sourceBreakpointLine = 13 + , sourceBreakpointCondition = Just "im IM.! 0 == 2" } + -- Continuing just once is sufficient for it to exit now + (continueThread 0) + +hitCount :: Assertion +hitCount = + testWith True + defaultSourceBreakpoint + { sourceBreakpointLine = 13 + , sourceBreakpointHitCondition = Just "2" + -- this ^ ignores 2 hits and stops at third. + } + -- Unlike conditional expression, we hit the breakpoint every time + -- after the ignore count, so run this twice + (continueThread 0 >> continueThread 0) + +testWith :: Bool -> SourceBreakpoint -> TestDAP () -> Assertion +testWith needsForcing bp afterCheck = + withTestDAPServer "test/integration/T111" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "T111.hs" + + _ <- sync $ launchWith cfg + waitFiltering_ EventTy "initialized" + _ <- sync $ setBreakpointsIn test_dir "T111.hs" [bp] + _ <- sync configurationDone + assertStoppedLocation DAP.StoppedEventReasonBreakpoint 13 + + -- This assertion validates: + -- 1) we only stopped when im IM.! 0 == 2 (and not earlier) + -- 2) or we only stopped on the third iteration + -- This test is run with two different breakpoints to trigger the two + -- cases, but both are validated the same way. + vars <- fetchLocalVars + -- In the expression conditional case, we have already forced IM to evaluate the condition + -- In the hit conditional case, we haven't evaluated IM so we need to. + im <- (if needsForcing then forceLazy else pure) (vars % "im") + + im @==? "IntMap" + imChild <- expandVar im + let _2v = imChild % "0" + _3v = imChild % "2" + _2v @==? "2" + _3v @==? "4" + afterCheck + waitForExitCode 0 + disconnect diff --git a/test/haskell/Test/Integration/Evaluate.hs b/test/haskell/Test/Integration/Evaluate.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Evaluate.hs @@ -0,0 +1,40 @@ +-- | Evaluate request tests (issue #116) ported from the NodeJS testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.Evaluate (evaluateTests) where + +import Control.Monad.IO.Class (liftIO) +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import qualified DAP + +evaluateTests :: TestTree +evaluateTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Evaluate" + [ testCase "Return structured representation for evaluated expressions (issue #116)" + evaluateStructured + ] + +evaluateStructured :: Assertion +evaluateStructured = + withTestDAPServer "test/integration/T116" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "T116.hs" + hitBreakpointWith cfg 13 + + resp <- evaluate "IM.delete 0 (IM.insert 0 'a' (IM.insert 1 'b' IM.empty))" + liftIO $ assertEqual "result is IntMap" "IntMap" (DAP.evaluateResponseResult resp) + respChildren <- fetchChildren (DAP.evaluateResponseVariablesReference resp) + -- fixme: it'd be good to re-use the VarViews structure here, but that's specialized to Variables for now + case filter (\v -> DAP.variableName v == "1") respChildren of + (v1:_) -> v1 @==? "\'b\'" + [] -> liftIO $ assertFailure $ + "No variable named 1 in evaluation result: " ++ show respChildren + disconnect diff --git a/test/haskell/Test/Integration/Exceptions.hs b/test/haskell/Test/Integration/Exceptions.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Exceptions.hs @@ -0,0 +1,69 @@ +-- | Exception info tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Test.Integration.Exceptions (exceptionTests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Test.DAP +import Test.DAP.Messages.Parser (Event(..)) +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import qualified DAP + +exceptionTests :: TestTree +exceptionTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Exceptions" + [ testCase "reports nested exceptions and continues after the first break" nestedExceptions + ] + +-- Note: It is not clear that stopping 5 times is the right thing to happen +-- here, but it just tests the existing behaviour. +nestedExceptions :: Assertion +nestedExceptions = + withTestDAPServer "test/integration/exceptions" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + _ <- sync $ launchWith cfg + waitFiltering_ EventTy "initialized" + setBreakOnException + _ <- sync configurationDone + checkNested + disconnect + where + assertExcMessage :: String -> T.Text -> (DAP.ExceptionDetails -> IO ()) -> TestDAP () + assertExcMessage descr expected k = do + -- Read next "stopped" event and its thread id + Event{eventBody = Just DAP.StoppedEvent{DAP.stoppedEventReason, DAP.stoppedEventThreadId}} + <- waitFiltering EventTy "stopped" + liftIO $ assertEqual (descr ++ ": should be an exception") DAP.StoppedEventReasonException stoppedEventReason + let tid = maybe (error "no tid?") id stoppedEventThreadId + info <- exceptionInfo tid + let details = DAP.exceptionInfoResponseDetails info + liftIO $ case details of + Nothing -> assertFailure $ descr ++ ": exception details should be present" + Just d -> do + assertEqual (descr ++ ": message") + (Just (T.unpack expected)) (DAP.exceptionDetailsMessage d) + k d + continueThread tid + + checkNested :: TestDAP () + checkNested = do + assertExcMessage "first exception" "outer boom" $ \details -> do + case DAP.exceptionDetailsInnerException details of + Nothing -> pure () + Just [] -> pure () + Just _ -> assertFailure "First exception should not have inner exceptions" + assertExcMessage "second exception" "inner boom" $ const $ pure () + assertExcMessage "third exception" "inner boom" $ const $ pure () + assertExcMessage "fourth exception" "inner boom" $ const $ pure () + assertExcMessage "fifth exception" "inner boom" $ const $ pure () + waitFiltering_ EventTy "terminated" diff --git a/test/haskell/Test/Integration/LogMessage.hs b/test/haskell/Test/Integration/LogMessage.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/LogMessage.hs @@ -0,0 +1,82 @@ +-- | 'logMessage'/'logPoints' tests +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Test.Integration.LogMessage (logMessageTests) where + +import Control.Monad.IO.Class (liftIO) +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import DAP (SourceBreakpoint(..), defaultSourceBreakpoint, OutputEvent (..)) +import Test.DAP.Messages.Parser (Event(..)) + +logMessageTests :: TestTree +logMessageTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.LogMessage" + [ + testGroup "breakpoint with logMessage" + [ testCase "fixed message" $ + simpleTest + "unique log message string" + "unique log message string" + , testCase "interpolation" $ + simpleTest + "f lcl = {f lcl}" + "f lcl = f local" + , testCase "escape in message" $ + simpleTest "\\{ }" "{ }" + , testCase "escape in antiquote" $ + simpleTest "{ show $ R { field = 1 \\} }" + "R {field = 1}" + , testCase "overloaded list" $ simpleTest + "{ show $ ([1,2,3] :: R) }" "R {field = 1}" + , testCase "log only when condition" $ + conditionTest + ] + ] + +simpleTest :: String -> String -> IO () +simpleTest tmpl expected = do + let bp = defaultSourceBreakpoint + { sourceBreakpointLine = 18 + , sourceBreakpointLogMessage = Just (T.pack tmpl) } + logMessageTestSetup [] [bp] $ do + assertOutput (T.pack expected) + +conditionTest :: IO () +conditionTest = logMessageTestSetup [] bps $ do + events <- waitAccumulating EventTy "output" + let output = T.concat $ map (outputEventOutput . fromMaybe (error "conditionTest:fromMaybe") . eventBody) events + + liftIO $ assertBool "logged when False" $ + not $ "DO NOT LOG" `T.isInfixOf` output + liftIO $ assertBool "did not log when True" $ + "DO LOG" `T.isInfixOf` output + return () + where + bps = + [ defaultSourceBreakpoint + { sourceBreakpointLine = 18 + , sourceBreakpointCondition = Just "False" + , sourceBreakpointLogMessage = Just "DO NOT LOG" } + , defaultSourceBreakpoint + { sourceBreakpointLine = 19 + , sourceBreakpointCondition = Just "True" + , sourceBreakpointLogMessage = Just "DO LOG" } + ] + +logMessageTestSetup :: [String] -> [SourceBreakpoint] -> TestDAP a -> IO () +logMessageTestSetup flags bps check = + withTestDAPServer "test/integration/T113" flags $ \test_dir server -> + withTestDAPServerClient server $ do + _ <- sync $ launchWith (mkLaunchConfig test_dir "Main.hs") + waitFiltering_ EventTy "initialized" + _ <- sync $ setBreakpointsIn test_dir "Main.hs" bps + _ <- sync configurationDone + _ <- check + disconnect diff --git a/test/haskell/Test/Integration/MultiHomeUnit.hs b/test/haskell/Test/Integration/MultiHomeUnit.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/MultiHomeUnit.hs @@ -0,0 +1,52 @@ +-- | Multiple home unit tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.MultiHomeUnit (multiHomeUnitTests) where + +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif + +multiHomeUnitTests :: TestTree +multiHomeUnitTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.MultiHomeUnit" + [ testCase "should run program to the end" runToTheEnd + , testCase "should stop at break-point in the same home unit" sameHomeUnitBP + , testCase "should stop at break-point in different home unit 1" otherHomeUnitBP1 + , testCase "should stop at break-point in different home unit 2" otherHomeUnitBP2 + ] + +withCommonSetup :: (FilePath -> TestDAP ()) -> Assertion +withCommonSetup test = + withTestDAPServer "test/integration/cabal-mhu1" [] $ \test_dir server -> + withTestDAPServerClient server $ do + test test_dir + disconnect + +runToTheEnd :: Assertion +runToTheEnd = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" + runToEnd cfg + +sameHomeUnitBP :: Assertion +sameHomeUnitBP = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" + hitBreakpointWith cfg 8 + +otherHomeUnitBP1 :: Assertion +otherHomeUnitBP1 = withCommonSetup $ \test_dir -> do + -- Use bar/app/Main.hs as the entry file; set a breakpoint in a + -- *different* home unit (bar/src/Bar.hs). + let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" + hitBreakpointIn cfg "bar/src/Bar.hs" 8 + +otherHomeUnitBP2 :: Assertion +otherHomeUnitBP2 = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "bar/app/Main.hs" + hitBreakpointIn cfg "foo/src/Foo.hs" 6 diff --git a/test/haskell/Test/Integration/MultiMain.hs b/test/haskell/Test/Integration/MultiMain.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/MultiMain.hs @@ -0,0 +1,47 @@ +-- | Multi-main tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.MultiMain (multiMainTests) where + +import qualified Data.Text as T +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif + +multiMainTests :: TestTree +multiMainTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.MultiMain" + [ testCase "should run program to the end" runToTheEnd + , testCase "should stop at break-point" stopAtBreakpoint + , testCase "should run the right main" runRightMain + ] + +withCommonSetup :: (FilePath -> TestDAP ()) -> Assertion +withCommonSetup test = + withTestDAPServer "test/integration/multi-mains" [] $ \test_dir server -> + withTestDAPServerClient server $ do + test test_dir + disconnect + +runToTheEnd :: Assertion +runToTheEnd = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "app/Main.hs" + runToEnd cfg + +stopAtBreakpoint :: Assertion +stopAtBreakpoint = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "app/Main.hs" + hitBreakpointWith cfg 6 + +runRightMain :: Assertion +runRightMain = withCommonSetup $ \test_dir -> do + let cfg = mkLaunchConfig test_dir "second/Main.hs" + runToEnd cfg + assertFullOutput (T.pack "The right main") + assertNotFullOutput (T.pack "The bad main") diff --git a/test/haskell/Test/Integration/Persistent.hs b/test/haskell/Test/Integration/Persistent.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Persistent.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Test.Integration.Persistent (persistentTests) where + +import Control.Concurrent.Async +import qualified Data.Text as T +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +import Test.Utils +import qualified DAP +import Control.Exception (bracket) +import System.Environment (lookupEnv) + +persistentTests :: TestTree +persistentTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Persistent" + [ + testGroup "multiple sessions" + [ testCase "sequential" $ + testSequential [] $ simpleSessions 2 + , testCase "parallel" $ + testParallel [] $ simpleSessions 2 + , testGroup "cwd /= test_dir" $ do + let units = replicate 2 ("test/integration/T113",18) + [ testCase "sequential" $ testSequential' units [] $ simpleSessions' + , testCase "parallel" $ testParallel' units [] $ simpleSessions' + ] + , testGroup "multiple test_dirs" $ do + let units = concat $ replicate 2 + [ ("test/integration/T113",18) + , ("test/integration/T44" ,5) + ] + [ testCase "sequential" $ testSequential' units [] $ simpleSessions' + , testCase "parallel" $ testParallel' units [] $ simpleSessions' + ] + ] + ] + + +withServerTestSetup' :: [FilePath] -> [String] -> ([FilePath] -> TestDAPServer -> IO a) -> IO a +withServerTestSetup' [] _ _ = error "no test dirs" +withServerTestSetup' dirs0@(d0:_) flags check = do + keep_temp_dirs <- maybe False read <$> lookupEnv "KEEP_TEMP_DIRS" + withHermeticDir keep_temp_dirs d0 $ \server_dir -> + bracket (startTestDAPServer server_dir flags) + (testDAPServerCleanup) + (go keep_temp_dirs [] dirs0) + + where + go _keep acc [] server = check (reverse acc) server + go keep acc (d:ds) server = withHermeticDir keep d $ \test_dir -> + go keep (test_dir:acc) ds server + +withBreakPoints :: [DAP.SourceBreakpoint] -> TestDAP () -> (FilePath, TestDAPServer) -> IO () +withBreakPoints bps check (test_dir, server) = + withTestDAPServerClient server $ do + _ <- sync $ launchWith (mkLaunchConfig test_dir "Main.hs") + waitFiltering_ EventTy "initialized" + _ <- sync $ setBreakpointsIn test_dir "Main.hs" bps + _ <- sync configurationDone + _ <- check + disconnect + +testSequential :: Foldable t => [String] -> ((FilePath, TestDAPServer) -> t (IO a)) -> IO () +testSequential flags k + = withTestDAPServer "test/integration/T113" flags + (curry $ \ x -> sequence_ $ k x) + +testSequential' :: Foldable t => + [(FilePath,Int)] -> + [String] -> + ([Int] -> ([FilePath], TestDAPServer) -> t (IO a)) -> + IO () +testSequential' (unzip -> (dirs,bps)) flags k + = withServerTestSetup' dirs flags + (curry $ \ x -> sequence_ $ k bps x) + +testParallel :: Foldable f => [String] -> ((FilePath, TestDAPServer) -> f (IO b)) -> IO () +testParallel flags k + = withTestDAPServer "test/integration/T113" flags + (curry $ \ x -> mapConcurrently_ id (k x)) + +testParallel' :: Foldable f => + [(FilePath,Int)] -> + [String] -> + ([Int] -> ([FilePath], TestDAPServer) -> f (IO b)) -> + IO () +testParallel' (unzip -> (dirs,bps)) flags k + = withServerTestSetup' dirs flags + (curry $ \ x -> mapConcurrently_ id (k bps x)) + +simpleSessions :: Int -> (FilePath, TestDAPServer) -> [IO ()] +simpleSessions n x = do + let bp msg = DAP.defaultSourceBreakpoint + { DAP.sourceBreakpointLine = 18 + , DAP.sourceBreakpointLogMessage = Just (T.pack msg) } + [ withBreakPoints [bp msg] check x + | i <- [(0::Int)..n] + , let msg = "MSG_" ++ show i + , let + check = do + assertOutput (T.pack msg) + waitFiltering_ EventTy "exited" + ] + +simpleSessions' :: [Int] -> ([FilePath], TestDAPServer) -> [IO ()] +simpleSessions' ls (dirs,server) = do + let bps line msg = + [ DAP.defaultSourceBreakpoint + { DAP.sourceBreakpointLine = line + , DAP.sourceBreakpointLogMessage = Just (T.pack msg) } + , DAP.defaultSourceBreakpoint + { DAP.sourceBreakpointLine = line + 1 } + ] + [ withBreakPoints (bps line msg) check (d,server) + | (i,(line,d)) <- zip [(0::Int)..] $ zip ls dirs + , let msg = "MSG_" ++ show i + , let + check = do + assertOutput (T.pack msg) + waitFiltering_ EventTy "stopped" + ] diff --git a/test/haskell/Test/Integration/RunInTerminal.hs b/test/haskell/Test/Integration/RunInTerminal.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/RunInTerminal.hs @@ -0,0 +1,116 @@ +-- | 'runInTerminal' tests +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +module Test.Integration.RunInTerminal (runInTerminalTests) where + +import Data.List (isInfixOf) +import System.FilePath +import System.IO +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified System.Process as P +import Control.Concurrent.Async +import Control.Monad.Reader + +runInTerminalTests :: TestTree +runInTerminalTests = + testGroup "DAP.RunInTerminal" + [ +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "runInTerminal: proxy forwards stdin correctly" + [ testCase "(default)" (runInTerminal1 []) + , testCase "(--internal-interpreter)" (runInTerminal1 ["--internal-interpreter"]) + ] + ] + +runInTerminal1 :: [String] -> IO () +runInTerminal1 flags = do + withTestDAPServer "test/integration/T44" flags $ \ test_dir server -> do + + let out_path = test_dir ("runInTerm" <.> "out") + err_path = test_dir ("runInTerm" <.> "err") + + withTestDAPServerClientWith True (\_ _ -> pure Nothing) server $ do + + ctx <- ask + (rit_in, rit_p) <- liftIO $ snd <$> + concurrently + (runTestDAP (hitBreakpointWith (mkLaunchConfig test_dir "Main.hs") 6) ctx) + (flip runTestDAP ctx $ + handleRunInTerminal $ \args -> do + (ritEnv, ritArgs) <- liftIO $ wait args + let invocation = T.unpack $ "/usr/bin/env " <> addRITEnv ritEnv <> " " <> T.unwords ritArgs + -- Redirect the child's stdout/stderr to files so logs are + -- persisted incrementally and survive test failures. + out_h <- liftIO $ openFile out_path WriteMode + err_h <- liftIO $ openFile err_path WriteMode + liftIO $ hPutStrLn out_h ("Invocation: " ++ invocation) + liftIO $ hPutStrLn err_h ("Invocation: " ++ invocation) + liftIO $ hFlush out_h + liftIO $ hFlush err_h + (Just rit_in, Nothing, Nothing, rit_p) + <- liftIO $ P.createProcess (P.shell invocation) + {P.cwd = Just test_dir, P.std_in = P.CreatePipe, P.std_out = P.UseHandle out_h, P.std_err = P.UseHandle err_h} + Just rit_pid <- liftIO $ P.getPid rit_p + pure ((rit_in, rit_p), fromIntegral rit_pid)) + + -- Continue from "getLine" which will block waiting for input + next + + let secret_in = "SOMETHING_SECRET" + + -- Time to write to the stdin of the rit process + liftIO $ hSetBuffering rit_in LineBuffering + liftIO $ hPutStrLn rit_in secret_in + + -- Only after writing should we receive the next "stopped" event + waitFiltering_ EventTy "stopped" + + -- To next line, which should be the "putStrLn" after the "getLine" + next + + -- Wait for the program to actually execute `print arg` and pause at the + -- next line before disconnecting; without this wait, disconnect can kill + -- the process before the output is flushed. + waitFiltering_ EventTy "stopped" + + -- Send disconnect + disconnect + + liftIO $ do + -- Wait for the child to exit so all buffered output lands on disk, + -- then read back the logs that were streamed to the files. + _ <- P.waitForProcess rit_p + out_str <- readFile out_path + err_str <- readFile err_path + + assertBool + ("Expected output to contain 'hello', got: " ++ out_str) + ("hello" `isInfixOf` out_str) + assertBool + ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ out_str) + (secret_in `isInfixOf` out_str) + + assertBool + ("The stderr of the runInTerminal process shouldn't have any errors, but has: " ++ err_str ++ "\nStdout: " ++ out_str) + (not ("GHCi.Message.readPipe:" `isInfixOf` err_str) && not ("Uncaught exception" `isInfixOf` err_str)) + + -- -- Kill the process + P.terminateProcess rit_p + + where + addRITEnv :: Maybe (H.HashMap T.Text T.Text) -> T.Text + addRITEnv env = + case env of + Nothing -> "" + Just ev -> T.unwords [k{-todo: escape-} <> "=" <> v | (k,v) <- H.toList ev] diff --git a/test/haskell/Test/Integration/Scopes.hs b/test/haskell/Test/Integration/Scopes.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Scopes.hs @@ -0,0 +1,43 @@ +-- | 'scopes' request tests +{-# LANGUAGE OverloadedStrings, CPP #-} +module Test.Integration.Scopes (scopesTests) where + +import Control.Monad.IO.Class (liftIO) +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import DAP (threadId, stackFrameId, scopeName, scopeExpensive) +import Data.List (find) +import qualified Data.Text as T + +scopesTests :: TestTree +scopesTests = + testGroup "DAP.Scopes" + [ +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testCase "Locals is cheap, Module/Globals are expensive" scopesExpensiveTest + ] + +scopesExpensiveTest :: Assertion +scopesExpensiveTest = withTestDAPServer "test/integration/T44" [] $ \ test_dir server -> + + withTestDAPServerClient server $ do + + _ <- hitBreakpointWith (mkLaunchConfig test_dir "Main.hs") 6 + + thread:_ <- threads + frame:_ <- stackTrace (threadId thread) + scps <- scopes (stackFrameId frame) + + let lookupExpensive n = scopeExpensive <$> find ((== T.pack n) . scopeName) scps + liftIO $ assertEqual "Locals should not be expensive" (Just False) (lookupExpensive "Locals") + liftIO $ assertEqual "Module should be expensive" (Just True) (lookupExpensive "Module") + liftIO $ assertEqual "Globals should be expensive" (Just True) (lookupExpensive "Globals") + + disconnect + pure () diff --git a/test/haskell/Test/Integration/StackTrace.hs b/test/haskell/Test/Integration/StackTrace.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/StackTrace.hs @@ -0,0 +1,59 @@ +-- | Stack trace tests (issues #107, #159) ported from the NodeJS testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.StackTrace (stackTraceTests) where + +import Control.Monad.IO.Class (liftIO) +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import DAP (threadId, stackFrameName) + +stackTraceTests :: TestTree +stackTraceTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.StackTrace" + [ testCase "contains mixed IPE and breakpoint frames (issue #107)" mixedFramesTest + , testCase "displays stack annotation frames (issue #159)" stackAnnotationsTest + ] + +mixedFramesTest :: Assertion +mixedFramesTest = + withTestDAPServer "test/integration/T107a" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "app/Main.hs" + hitBreakpointWith cfg 9 + t:_ <- threads + frames <- stackTrace (threadId t) + let names = map stackFrameName frames + liftIO $ do + -- Contains the interpreter frame + assertBool ("should contain Main.main.a: " ++ show names) + ("Main.main.a" `elem` names) + -- Contains the IPE frame + assertBool ("should contain MyLib.thenDo: " ++ show names) + ("MyLib.thenDo" `elem` names) + disconnect + +stackAnnotationsTest :: Assertion +stackAnnotationsTest = + withTestDAPServer "test/integration/T159" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "app/Main.hs" + hitBreakpointWith cfg 15 + t:_ <- threads + frames <- stackTrace (threadId t) + let names = map stackFrameName frames + liftIO $ do + -- Contains the stack annotations + assertBool ("should contain 'Lovely annotation': " ++ show names) + ("Lovely annotation" `elem` names) + assertBool ("should contain '[1,2,3,4]': " ++ show names) + ("[1,2,3,4]" `elem` names) + disconnect + diff --git a/test/haskell/Test/Integration/Stdout.hs b/test/haskell/Test/Integration/Stdout.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Stdout.hs @@ -0,0 +1,38 @@ +-- | Stdout/stderr tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.Stdout (stdoutTests) where + +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif + +stdoutTests :: TestTree +stdoutTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Stdout" + [ testCase "basic output and stderr" basicOutputTest + ] + +basicOutputTest :: Assertion +basicOutputTest = + withTestDAPServer "test/integration/T45" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + -- Hit breakpoint at line 3 before program runs through. + hitBreakpointWith cfg 3 + next -- Print line + next -- Reach crash line + next -- Crash it + waitFiltering_ EventTy "terminated" + + -- Assert both stdout and stderr appeared somewhere in the accumulated + -- full output. + assertFullOutput "Going to read args" + assertFullOutput "Uncaught exception" + disconnect diff --git a/test/haskell/Test/Integration/StepOut.hs b/test/haskell/Test/Integration/StepOut.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/StepOut.hs @@ -0,0 +1,72 @@ +-- | Step-out tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.StepOut (stepOutTests) where + +import DAP (StoppedEventReason(..)) +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif + +-- Currently we depend on this to work around the fact that '>>=' is in library +-- code because @base@ is not being interpreted. +need_opt :: Bool +need_opt = True + +stepOutTests :: TestTree +stepOutTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.StepOut" + [ testCase "simple step-out to case" simpleStepOutCase + , testCase "without tail calls (T26042b)" withoutTailCalls + , testCase "with tail calls (T26042c)" withTailCalls + ] + +optFlags :: [String] +optFlags = if need_opt then ["-O", "-fno-unoptimized-core-for-interpreter"] else [] + +withCommon :: String -> Int -> [String] -> TestDAP () -> Assertion +withCommon entry line flags act = + withTestDAPServer "test/integration/T6" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = (mkLaunchConfig test_dir entry) { lcExtraGhcArgs = flags } + hitBreakpointWith cfg line + act + +simpleStepOutCase :: Assertion +simpleStepOutCase = withCommon "MainC.hs" 9 [] $ do + stepOut 0 + assertStoppedLocation StoppedEventReasonStep 5 + disconnect + +withoutTailCalls :: Assertion +withoutTailCalls = withCommon "MainA.hs" 10 optFlags $ do + -- foo to bar + stepOut 0 + assertStoppedLocation StoppedEventReasonStep 20 + stepOut 0 + -- bar back to foo + assertStoppedLocation StoppedEventReasonStep 14 + stepOut 0 + -- back to main + assertStoppedLocation StoppedEventReasonStep 5 + -- exit + stepOut 0 + disconnect + +-- Mimics GHC's T26042c +withTailCalls :: Assertion +withTailCalls = withCommon "MainB.hs" 10 optFlags $ do + -- step out of foo True and observe that we have skipped its call in bar, + -- and the call of bar in foo False. + -- we go straight to `main`. + stepOut 0 + assertStoppedLocation StoppedEventReasonStep 5 + -- stepping out again exits + stepOut 0 + disconnect diff --git a/test/haskell/Test/Integration/Variables.hs b/test/haskell/Test/Integration/Variables.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Integration/Variables.hs @@ -0,0 +1,321 @@ +-- | Variable inspection tests ported from the NodeJS integration testsuite. +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.Integration.Variables (variableTests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +#ifdef mingw32_HOST_OS +import Test.Tasty.ExpectedFailure +#endif +import DAP (Variable, variableValue) + +variableTests :: TestTree +variableTests = +#ifdef mingw32_HOST_OS + ignoreTestBecause "Needs to be fixed for Windows (#199)" $ +#endif + testGroup "DAP.Integration.Variables" + [ testCase "ints and strings should be displayed as values" intsAndStringsTest + , testCase "arbitrarily deep inspection (issues #8, #9)" deepInspectionTest + , testCase "string fields of expanded vars are fully evaluated (issue #11)" stringFieldsTest + , testCase "labeled data structures can be expanded (issue #18)" labeledTest + , testCase "newtype vars not broken (issue #55)" newtypeTest + , testCase "dont crash on inspect newtype con (issue #64)" newtypeConTest + , testCase "expand iteratively (issue #97)" expandIterTest + , testCase "inspect mutable variables (#92)" mutableVarsTest + , testCase "inspect fully evaluated type (issue #110)" fullyEvaluatedTest + , testCase "user-defined custom instance (issue #47a)" customInstanceTest + , testCase "built-in custom instance (issue #47b)" builtinCustomInstanceTest + , testCase "hdv with containers (issue #47c)" hdvContainersDepTest + , testCase "hdv in-memory with containers (issue #47d)" hdvContainersMemTest + , testCase "hdv in-memory with text (issue #47e)" hdvTextMemTest + ] + +intsAndStringsTest :: Assertion +intsAndStringsTest = + withTestDAPServer "test/integration/cabal1" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = (mkLaunchConfig test_dir "app/Main.hs") + { lcEntryArgs = ["some", "args"] } + hitBreakpointWith cfg 15 + + vars <- fetchLocalVars + let a = vars % "a" + b = vars % "b" + a @==? "2" + b @==? "4" + + -- Strings are forced and displayed whole rather than as a structure + let c = vars % "c" + cForced <- forceLazy c + assertIsString cForced "\"call_fxxx\"" + + -- After a variable is forced, a new locals request is done. Check again for c == call_fxxx afterwards + vars2 <- fetchLocalVars + let c2 = vars2 % "c" + assertIsString c2 "\"call_fxxx\"" + + disconnect + +deepInspectionTest :: Assertion +deepInspectionTest = + withTestDAPServer "test/integration/simple2" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 19 + + locals <- fetchLocalVars + p <- forceLazy (locals % "p") + pChild <- expandVar p + _1 <- forceLazy (pChild % "_1") + assertIsString _1 "\"d=1\"" + + -- Walk the spine from d=2 through d=6 + let walk focus level + | level > 6 = pure focus + | otherwise = do + forced <- forceLazy focus + children <- expandVar forced + dChild <- forceLazy (children % "_1") + assertIsString dChild (T.pack $ "\"d=" ++ show level ++ "\"") + walk (children % "_2") (level + 1) + + finalFocus <- walk (pChild % "_2") (2 :: Int) + + -- Finally, we should be at the OK constructor + finalFocus @==? "OK" + disconnect + +stringFieldsTest :: Assertion +stringFieldsTest = + withTestDAPServer "test/integration/repeat" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 5 + + -- Force only the 1st "hello" and check the 2nd is already there. + -- (Mimics reproducer in #11) + locals <- fetchLocalVars + x <- forceLazy (locals % "x") + xChild <- expandVar x + -- Force the zeroth element + _ <- forceLazy (xChild % "0") + + -- Refresh the local variables + locals2 <- fetchLocalVars + xChild2 <- expandVar (locals2 % "x") + let _0v = xChild2 % "0" + _1v = xChild2 % "1" + _0v @==? "\"hello\"" + _1v @==? "\"hello\"" + disconnect + +labeledTest :: Assertion +labeledTest = + withTestDAPServer "test/integration/labeled" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 8 + + -- Force only the 2nd "hello" and check the third is already there. + -- It relies on repeat seemingly only re-using every other thunk?!!? + -- (Mimics reproducer in #11) + locals <- fetchLocalVars + x <- forceLazy (locals % "x") + xChild <- expandVar x + let sNew = xChild % "new" -- No force! + sNew @==? "3456" + sLab <- forceLazy (xChild % "lab") + assertIsString sLab "\"label\"" + disconnect + +newtypeTest :: Assertion +newtypeTest = + withTestDAPServer "test/integration/T55" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 40 + + locals <- fetchLocalVars + y2 <- forceLazy (locals % "y2") + y2 @==? "Y2 (MyIntX (X _))" + y2c <- expandVar y2 + let y21 = y2c % "_1" + y21 @==? "MyIntX (X _)" + y21c <- expandVar y21 + let y211 = y21c % "_1" + y211 @==? "X" + y211c <- expandVar y211 + y2111 <- forceLazy (y211c % "_1") + y2111 @==? "MyInt 42" + disconnect + +newtypeConTest :: Assertion +newtypeConTest = + withTestDAPServer "test/integration/T64" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 4 + + modVars <- fetchModuleVars + let myIntConVars = modVars %% "MyIntCon" + liftIO $ assertBool ("Expecting: Data constructor ‘MyIntCon’; but got " ++ show myIntConVars) + (any ((== "Data constructor ‘MyIntCon’") . variableValue) myIntConVars) + disconnect + +expandIterTest :: Assertion +expandIterTest = + withTestDAPServer "test/integration/T97" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 12 + + locals <- fetchLocalVars + let y = locals % "y" + -- NOTE: This tests that we don't have to force a single variable + -- as we expand because the data should be fully forced at this + -- point. + yChild <- expandVar y + let v1 = yChild % "_1" + v1c <- expandVar v1 + let v11 = v1c % "_1" + v11 @==? "T97" -- just check + v11c <- expandVar v11 + let v111 = v11c % "_1" + v111c <- expandVar v111 + let v1111 = v111c % "_1" + v1111c <- expandVar v1111 + let v11111 = v1111c % "_1" + v11111c <- expandVar v11111 + let v111111 = v11111c % "_1" + assertIsString v111111 "\"hello\"" + disconnect + +mutableVarsTest :: Assertion +mutableVarsTest = + withTestDAPServer "test/integration/T92" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "T92.hs" + hitBreakpointWith cfg 7 + + let getMutVarValue :: String -> TestDAP Variable + getMutVarValue expectedInner = do + locals <- fetchLocalVars + let r = locals % "r" + r @==? "IORef (STRef (GHC.Prim.MutVar# _))" + rc <- expandVar r + let r1 = rc % "_1" -- No force + r1 @==? "STRef" + r1c <- expandVar r1 + let r11 = r1c % "_1" -- No force + r11 @==? T.pack ("GHC.Prim.MutVar# " ++ expectedInner) + r11c <- expandVar r11 + pure (r11c % "_1") + + m1 <- getMutVarValue "False" + m1 @==? "False" + next; next; next + -- Now we're at the start of the last line, where the ref should be True + -- Note how we get it from scratch, the content of the ref must be + -- forced again (the forceLazy call in getMutVarValue) + m2 <- getMutVarValue "True" + m2 @==? "True" + disconnect + +fullyEvaluatedTest :: Assertion +fullyEvaluatedTest = + withTestDAPServer "test/integration/T110" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "T110.hs" + hitBreakpointWith cfg 11 + locals <- fetchLocalVars + t <- forceLazy (locals % "t") + t @==? "T" + tChild <- expandVar t -- No force needed, is fully evaluated and can expand + let v1 = tChild % "_1" + v2 = tChild % "_2" + v1 @==? "333" + v2 @==? "34" + disconnect + +customInstanceTest :: Assertion +customInstanceTest = + withTestDAPServer "test/integration/T47a" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 26 + locals <- fetchLocalVars + action <- forceLazy (locals % "action") + action @==? "SDJFLSKDJFLKSDJFLSJDKFL" + ac <- expandVar action + f1 <- forceLazy (ac % "field1") + f1 @==? "\"A33\"" + f2 <- forceLazy (ac % "myfield2") + f2 @==? "3" + f3 <- forceLazy (ac % "field3") + f3 @==? "Y" + f3c <- expandVar f3 + f31 <- forceLazy (f3c % "_1") + f31 @==? "\"7\"" + let f4 = ac % "field4" + f5 = ac % "field5" + f4 @==? "2345" + f5 @==? "2345.0" + disconnect + +builtinCustomInstanceTest :: Assertion +builtinCustomInstanceTest = + withTestDAPServer "test/integration/T47b" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 11 + locals <- fetchLocalVars + action <- forceLazy (locals % "action") + action @==? "X" + ac <- expandVar action + let v1 = ac % "_1" + v1 @==? "( , )" + v1c <- expandVar v1 + v2 <- forceLazy (v1c % "fst") + v2 @==? "\"A33\"" + let v3 = v1c % "snd" + v3 @==? "3456.0" + disconnect + +hdvContainersDepTest :: Assertion +hdvContainersDepTest = hdvIntMapTest "test/integration/T47c" "Main.hs" 13 + +hdvContainersMemTest :: Assertion +hdvContainersMemTest = hdvIntMapTest "test/integration/T47d" "Main.hs" 11 + +hdvIntMapTest :: FilePath -> FilePath -> Int -> Assertion +hdvIntMapTest dir entry line = + withTestDAPServer dir [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir entry + hitBreakpointWith cfg line + -- Check IntMap custom view + locals <- fetchLocalVars + action <- forceLazy (locals % "action") + action @==? "IntMap" + ac <- expandVar action + v1 <- forceLazy (ac % "3") + v1 @==? "\"one\"" + v2 <- forceLazy (ac % "2") + v2 @==? "\"two\"" + disconnect + +hdvTextMemTest :: Assertion +hdvTextMemTest = + withTestDAPServer "test/integration/T47e" [] $ \test_dir server -> + withTestDAPServerClient server $ do + let cfg = mkLaunchConfig test_dir "Main.hs" + hitBreakpointWith cfg 11 + locals <- fetchLocalVars + action <- forceLazy (locals % "action") + action @==? "\"this should be displayed as a simple string\"" + disconnect diff --git a/test/haskell/Test/Utils.hs b/test/haskell/Test/Utils.hs --- a/test/haskell/Test/Utils.hs +++ b/test/haskell/Test/Utils.hs @@ -1,5 +1,8 @@ module Test.Utils where +import Control.Monad (when) +import Data.List (isInfixOf) +import System.Directory (doesFileExist) import System.FilePath import System.IO.Temp import qualified System.Process as P @@ -13,7 +16,13 @@ withHermeticDir keep src k = do withTmpDir "hdb-test" $ \dest -> do P.callCommand $ "cp -r " ++ src ++ " " ++ dest - k (dest takeBaseName src) + let destTestDir = dest takeBaseName src + -- Some test projects reference @./haskell-debugger-view@ in their + -- @cabal.project@. If such a dir is expected, copy the in-tree + -- @haskell-debugger-view@ there so that cabal can resolve it when + -- building the test project from its hermetic copy. + cpHaskellDebuggerViewIfNeeded destTestDir + k destTestDir where withTmpDir | keep = withPersistentSystemTempDirectory | otherwise = withSystemTempDirectory @@ -22,4 +31,13 @@ withPersistentSystemTempDirectory template k' = do dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory k' dir + + cpHaskellDebuggerViewIfNeeded testDir = do + let cabalProject = testDir "cabal.project" + existsCP <- doesFileExist cabalProject + when existsCP $ do + contents <- readFile cabalProject + when ("haskell-debugger-view" `isInfixOf` contents) $ + P.callCommand $ + "cp -r haskell-debugger-view " ++ testDir "haskell-debugger-view" diff --git a/test/integration/T107a/app/Main.hs b/test/integration/T107a/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T107a/app/Main.hs @@ -0,0 +1,11 @@ +module Main (main) where + +import MyLib + + +main :: IO () +main = a `thenDo` ("before" ++ "OK ") + where + a x = do + putStrLn x + pure (x++"hi2b") diff --git a/test/integration/T107a/b/b.cabal b/test/integration/T107a/b/b.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T107a/b/b.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: b +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall -finfo-table-map + +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/integration/T107a/b/src/MyLib.hs b/test/integration/T107a/b/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/test/integration/T107a/b/src/MyLib.hs @@ -0,0 +1,6 @@ +module MyLib (thenDo) where + +thenDo :: (String -> IO String) -> String -> IO () +thenDo a b = do + print =<< a ("test" ++ b) +{-# OPAQUE thenDo #-} diff --git a/test/integration/T107a/cabal.project b/test/integration/T107a/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/T107a/cabal.project @@ -0,0 +1,1 @@ +packages: . b diff --git a/test/integration/T107a/hie.yaml b/test/integration/T107a/hie.yaml new file mode 100644 --- /dev/null +++ b/test/integration/T107a/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + components: "exe:t3" diff --git a/test/integration/T107a/t3.cabal b/test/integration/T107a/t3.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T107a/t3.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: t3 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable t3 + import: warnings + main-is: Main.hs + build-depends: base, b + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/integration/T110/T110.hs b/test/integration/T110/T110.hs new file mode 100644 --- /dev/null +++ b/test/integration/T110/T110.hs @@ -0,0 +1,11 @@ +module Main where + +data T = T !Int !Int + deriving Show + +main = do + y (T 333 34) + +y :: T -> IO () +y t = do + print t diff --git a/test/integration/T111/T111.hs b/test/integration/T111/T111.hs new file mode 100644 --- /dev/null +++ b/test/integration/T111/T111.hs @@ -0,0 +1,22 @@ +module Main where + +import Data.IntMap +import qualified Data.IntMap as IM + +main = do + nn (IM.fromList [(0,345),(1,34),(46,345)]) + nn (IM.fromList [(0,1)]) + nn (IM.fromList [(0,2), (2,4)]) + nn (IM.fromList [(0,3)]) + +nn :: IntMap Int -> IO () +nn im = do + if False + then return () + else do + nnn im + return () + +nnn :: IntMap Int -> IO () +nnn im = do + const (return ()) im diff --git a/test/integration/T113/Main.hs b/test/integration/T113/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T113/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedLists, TypeFamilies #-} +import GHC.IsList + +data R = R { field :: Int } + deriving Show + +instance IsList R where + type Item R = Int + fromList [] = R 0 + fromList (x:_) = R x + toList (R x) = [x] + +f x = "f " ++ const x (show ([1,2,3] :: R)) + +main :: IO () +main = do + lcl <- pure "local" + pure () + pure () + pure () + putStrLn (f lcl) + putStrLn "goodbye" diff --git a/test/integration/T116/T116.hs b/test/integration/T116/T116.hs new file mode 100644 --- /dev/null +++ b/test/integration/T116/T116.hs @@ -0,0 +1,22 @@ +module Main where + +import Data.IntMap +import qualified Data.IntMap as IM + +main = do + nn (IM.fromList [(0,345),(1,34),(46,345)]) + nn (IM.fromList [(0,1)]) + nn (IM.fromList [(0,2), (2,4)]) + nn (IM.fromList [(0,3)]) + +nn :: IntMap Int -> IO () +nn im = do + if False + then return () + else do + nnn im + return () + +nnn :: IntMap Int -> IO () +nnn im = do + const (return ()) im diff --git a/test/integration/T159/T159.cabal b/test/integration/T159/T159.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T159/T159.cabal @@ -0,0 +1,12 @@ +cabal-version: 3.8 +name: T159 +version: 0.1.0.0 +build-type: Simple + +executable T159 + main-is: Main.hs + build-depends: base, + ghc-experimental, + hs-source-dirs: app, + default-language: Haskell2010 + ghc-options: -finfo-table-map diff --git a/test/integration/T159/app/Main.hs b/test/integration/T159/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T159/app/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import GHC.Stack.Annotation.Experimental + +main :: IO () +main = do + annotateCallStackIO $ do + annotateStackShowIO ([1..4] :: [Int]) $ do + annotateStackStringIO "Lovely annotation" $ do + foo 500 10 + +{-# OPAQUE foo #-} +foo :: Int -> Int -> IO () +foo arg arg2 = + putStrLn $ "foo: " <> show (arg * arg * arg2) diff --git a/test/integration/T159/cabal.project b/test/integration/T159/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/T159/cabal.project @@ -0,0 +1,2 @@ +packages: . + diff --git a/test/integration/T44/Main.hs b/test/integration/T44/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T44/Main.hs @@ -0,0 +1,8 @@ +import System.IO + +main :: IO () +main = do + putStrLn "hello" + arg <- getLine + print arg + putStrLn "goodbye" diff --git a/test/integration/T45/Main.hs b/test/integration/T45/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T45/Main.hs @@ -0,0 +1,6 @@ +import System.Environment (getArgs) +main :: IO () +main = do + putStrLn "Going to read args " + [arg] <- getArgs + putStrLn $ "Success...: " ++ arg diff --git a/test/integration/T47a/Main.hs b/test/integration/T47a/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T47a/Main.hs @@ -0,0 +1,26 @@ +module Main where +import GHC.Debugger.View.Class + +data X = X String + deriving Show + +data Y = Y String + deriving Show + +instance DebugView X where + debugValue _ = simpleValue "SDJFLSKDJFLKSDJFLSJDKFL" True + debugFields (X s) = pure $ VarFields + [ ("field1", (VarFieldValue s)) + , ("myfield2", (VarFieldValue (length s))) + , ("field4", (VarFieldValue (2345 :: Int))) + , ("field5", (VarFieldValue (2345 :: Double))) + -- important! test no-debug-view type inside of debug-view instance. this used to crash: + , ("field3", (VarFieldValue (Y (show (length "inner Y"))))) + ] + +main :: IO () +main = f (X "A33") + +f :: Show a => a -> IO () +f action = do + print action diff --git a/test/integration/T47a/T47a.cabal b/test/integration/T47a/T47a.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T47a/T47a.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.14 +name: T47a +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable t47a + import: warnings + main-is: Main.hs + build-depends: base, containers + build-depends: haskell-debugger-view + hs-source-dirs: . + default-language: Haskell2010 + diff --git a/test/integration/T47a/cabal.project b/test/integration/T47a/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/T47a/cabal.project @@ -0,0 +1,1 @@ +packages: . ./haskell-debugger-view/ diff --git a/test/integration/T47b/Main.hs b/test/integration/T47b/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T47b/Main.hs @@ -0,0 +1,11 @@ +module Main where + +data X = X (String, Double) + deriving Show + +main :: IO () +main = f (X ("A33", 3456)) + +f :: Show a => a -> IO () +f action = do + print action diff --git a/test/integration/T47c/Main.hs b/test/integration/T47c/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T47c/Main.hs @@ -0,0 +1,14 @@ +module Main where +import GHC.Debugger.View.Class +-- Look! I don't have to import the orphan instances! +-- import GHC.Debugger.View.Containers + +import qualified Data.IntMap as IM + +main :: IO () +main = f (IM.fromList [(3,"one"), (2,"two")]) + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration/T47c/T47a.cabal b/test/integration/T47c/T47a.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T47c/T47a.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.14 +name: T47a +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable t47a + import: warnings + main-is: Main.hs + build-depends: base, containers + build-depends: haskell-debugger-view + hs-source-dirs: . + default-language: Haskell2010 + diff --git a/test/integration/T47c/cabal.project b/test/integration/T47c/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/T47c/cabal.project @@ -0,0 +1,1 @@ +packages: . ./haskell-debugger-view/ diff --git a/test/integration/T47d/Main.hs b/test/integration/T47d/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T47d/Main.hs @@ -0,0 +1,12 @@ +module Main where +-- Look! No imports but still custom views for containers! + +import qualified Data.IntMap as IM + +main :: IO () +main = f (IM.fromList [(3,"one"), (2,"two")]) + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration/T47d/T47d.cabal b/test/integration/T47d/T47d.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T47d/T47d.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: T47d +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable T47d + import: warnings + main-is: Main.hs + build-depends: base, containers + hs-source-dirs: . + default-language: Haskell2010 diff --git a/test/integration/T47e/Main.hs b/test/integration/T47e/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T47e/Main.hs @@ -0,0 +1,12 @@ +module Main where +-- Look! No imports but still custom views for text! + +import qualified Data.Text as T + +main :: IO () +main = f (T.pack "this should be displayed as a simple string") + +f :: Show a => a -> IO () +f action = do + print action + diff --git a/test/integration/T47e/T47d.cabal b/test/integration/T47e/T47d.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T47e/T47d.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.14 +name: T47d +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple +extra-doc-files: CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable T47d + import: warnings + main-is: Main.hs + build-depends: base, text + hs-source-dirs: . + default-language: Haskell2010 diff --git a/test/integration/T55/Main.hs b/test/integration/T55/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T55/Main.hs @@ -0,0 +1,43 @@ +module Main where + +newtype MyInt = MyInt Int + deriving (Show) + +newtype MyIntX = MyIntX X + deriving (Show) + + +data X = X MyInt + deriving Show + +newtype Y = Y MyInt + deriving Show + +newtype Y2 = Y2 MyIntX + deriving Show + +data R = R {_fieldOfR :: MyInt} + deriving Show + +main :: IO () +main = do + putStrLn $ show $ bpmi $ MyInt 42 + putStrLn $ show $ bpx $ X (MyInt 42) + putStrLn $ show $ bpy $ Y (MyInt 42) + putStrLn $ show $ bpy2 $ Y2 (MyIntX (X (MyInt 42))) + putStrLn $ show $ bpr $ R (MyInt 42) + +bpmi :: MyInt -> MyInt +bpmi mi = mi + +bpx :: X -> X +bpx x = x + +bpy :: Y -> Y +bpy y = y + +bpy2 :: Y2 -> Y2 +bpy2 y2 = y2 + +bpr :: R -> R +bpr r = r diff --git a/test/integration/T6/MainA.hs b/test/integration/T6/MainA.hs new file mode 100644 --- /dev/null +++ b/test/integration/T6/MainA.hs @@ -0,0 +1,22 @@ +module Main where + +main :: IO () +main = do + a <- foo False undefined + print a + print a + +foo :: Bool -> Int -> IO Int +foo True i = return i +foo False _ = do + let x = 3 + y = 4 + n <- bar (x + y) + return n + +bar :: Int -> IO Int +bar z = do + let t = z * 2 + y <- foo True t + return y + diff --git a/test/integration/T6/MainB.hs b/test/integration/T6/MainB.hs new file mode 100644 --- /dev/null +++ b/test/integration/T6/MainB.hs @@ -0,0 +1,20 @@ +module Main where + +main :: IO () +main = do + a <- foo False undefined + print a + print a + +foo :: Bool -> Int -> IO Int +foo True i = return i +foo False _ = do + let x = 3 + y = 4 + bar (x + y) + +bar :: Int -> IO Int +bar z = do + let t = z * 2 + foo True t + diff --git a/test/integration/T6/MainC.hs b/test/integration/T6/MainC.hs new file mode 100644 --- /dev/null +++ b/test/integration/T6/MainC.hs @@ -0,0 +1,10 @@ +module Main where + +main :: IO () +main = do + case foo False undefined of + 1 -> putStrLn "one" + 2 -> putStrLn "two" + +foo = \b x -> if b then 1 else 2 + diff --git a/test/integration/T64/Main.hs b/test/integration/T64/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T64/Main.hs @@ -0,0 +1,5 @@ +newtype MyIntTy = MyIntCon Int + +main :: IO () +main = pure () + diff --git a/test/integration/T71/Main.hs b/test/integration/T71/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T71/Main.hs @@ -0,0 +1,2 @@ +main = do + putStrLn "T71 is running!" diff --git a/test/integration/T77/T77.cabal b/test/integration/T77/T77.cabal new file mode 100644 --- /dev/null +++ b/test/integration/T77/T77.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +name: T77 +version: 0.1.0.0 +license: BSD-3-Clause +license-file: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable T77 + import: warnings + main-is: Main.hs + build-depends: base ==4.20.1.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/integration/T77/app/Main.hs b/test/integration/T77/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T77/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/test/integration/T92/T92.hs b/test/integration/T92/T92.hs new file mode 100644 --- /dev/null +++ b/test/integration/T92/T92.hs @@ -0,0 +1,10 @@ +module Main where + +import Data.IORef + +main = do + r <- newIORef False + putStrLn (const "hi" r) -- make r free in this line + writeIORef r True + putStrLn (const "bye" r) -- what does r look like now? + diff --git a/test/integration/T97/Main.hs b/test/integration/T97/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/T97/Main.hs @@ -0,0 +1,13 @@ +module Main where + +data T97 a = T97 a + deriving Show + + +main = do + let y :: T97 (T97 (T97 (T97 (T97 (T97 String))))) + y = T97 (T97 (T97 (T97 (T97 (T97 "hello"))))) + + print y + print y + diff --git a/test/integration/cabal-mhu1/bar/app/Main.hs b/test/integration/cabal-mhu1/bar/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/bar/app/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Bar +import Foo + +main :: IO () +main = do + myFibonacciTest + print (fib 5) diff --git a/test/integration/cabal-mhu1/bar/bar.cabal b/test/integration/cabal-mhu1/bar/bar.cabal new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/bar/bar.cabal @@ -0,0 +1,20 @@ +cabal-version: 3.8 +name: bar +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Bar + build-depends: + base, + foo, + hs-source-dirs: src + default-language: Haskell2010 + +executable bar-exe + main-is: app/Main.hs + build-depends: + base, + bar, + foo, + default-language: Haskell2010 diff --git a/test/integration/cabal-mhu1/bar/src/Bar.hs b/test/integration/cabal-mhu1/bar/src/Bar.hs new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/bar/src/Bar.hs @@ -0,0 +1,10 @@ +module Bar where + +import Foo + +myFibonacciTest :: IO () +myFibonacciTest = do + print (fib 1) + print (fib 4) + print (fib 8) + print (fib 10) diff --git a/test/integration/cabal-mhu1/cabal.project b/test/integration/cabal-mhu1/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/cabal.project @@ -0,0 +1,3 @@ +packages: + ./foo + ./bar diff --git a/test/integration/cabal-mhu1/foo/foo.cabal b/test/integration/cabal-mhu1/foo/foo.cabal new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/foo/foo.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.8 +name: foo +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/integration/cabal-mhu1/foo/src/Foo.hs b/test/integration/cabal-mhu1/foo/src/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/foo/src/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +fib :: Int -> Int +fib n + | n <= 1 = 1 + | otherwise = fib (n - 1) + fib (n - 2) diff --git a/test/integration/cabal-mhu1/hie.yaml b/test/integration/cabal-mhu1/hie.yaml new file mode 100644 --- /dev/null +++ b/test/integration/cabal-mhu1/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: all diff --git a/test/integration/cabal1/app/Main.hs b/test/integration/cabal1/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/cabal1/app/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where +import Control.Exception +import System.Environment +main :: IO () +main = do + args <- getArgs + putStrLn "hello" + print args + fail "CATCH ME" `catch` (\(_::SomeException) -> putStrLn "caught it") + putStrLn "goodbye" + putStrLn (f 2 4 "call_fxxx") + +f :: Int -> Int -> String -> String +f a b c = show (a + b) <> " " <> c diff --git a/test/integration/cabal1/cabal.project b/test/integration/cabal1/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/cabal1/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/test/integration/cabal1/cabal1.cabal b/test/integration/cabal1/cabal1.cabal new file mode 100644 --- /dev/null +++ b/test/integration/cabal1/cabal1.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.14 +name: cabal1 +version: 0.1.0.0 +license: NONE +author: Rodrigo Mesquita +maintainer: rodrigo.m.mesquita@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable cabal1 + import: warnings + main-is: Main.hs + build-depends: base + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/integration/exceptions/Main.hs b/test/integration/exceptions/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/exceptions/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Exception + +main :: IO () +main = do + putStrLn "About to throw outer exception" + catch throwOuter handler + putStrLn "unreachable" + +throwOuter :: IO () +throwOuter = error "outer boom" + +handler :: SomeException -> IO () +handler se = do + putStrLn ("Handling exception: " ++ displayException se) + error "inner boom" diff --git a/test/integration/labeled/Main.hs b/test/integration/labeled/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/labeled/Main.hs @@ -0,0 +1,13 @@ +module Main where + +data Something = S { new :: Int, lab :: String } + deriving Show +main :: IO () +main = do + let x = f () + print x + +f :: () -> Something +{-# OPAQUE f #-} +f () = S { new = 3456, lab = "label" } + diff --git a/test/integration/multi-exes/a/a.cabal b/test/integration/multi-exes/a/a.cabal new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/a/a.cabal @@ -0,0 +1,12 @@ +cabal-version: 3.8 +name: a +version: 0.1.0.0 +build-type: Simple + + +executable a + main-is: Main.hs + build-depends: base + hs-source-dirs: app + ghc-options: -this-package-name a + default-language: Haskell2010 diff --git a/test/integration/multi-exes/a/app/Main.hs b/test/integration/multi-exes/a/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/a/app/Main.hs @@ -0,0 +1,14 @@ +module Main where + +main :: IO () +main = do + let y = sum [1..60] + let x = fib y + z = fib 500 + putStrLn $ "Hello, A!" ++ show (length (show x)) ++ show (z) + +fib :: Int -> Integer +fib n = fibs !! n + +fibs = 1: 1: zipWith (+) fibs (tail fibs) + diff --git a/test/integration/multi-exes/b/app/Main.hs b/test/integration/multi-exes/b/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/b/app/Main.hs @@ -0,0 +1,10 @@ +module Main where + +main :: IO () +main = do + let x = ackermann 3 3 + putStrLn $ "Hello, B! " ++ show (length (show x)) + +ackermann 0 m = m + 1 +ackermann n 0 = ackermann (n - 1) 1 +ackermann n m = ackermann (n - 1) (ackermann n (m - 1)) diff --git a/test/integration/multi-exes/b/b.cabal b/test/integration/multi-exes/b/b.cabal new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/b/b.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.8 +name: b +version: 0.1.0.0 +build-type: Simple + +executable b + main-is: Main.hs + build-depends: base + ghc-options: -this-package-name b + hs-source-dirs: app + default-language: Haskell2010 diff --git a/test/integration/multi-exes/cabal.project b/test/integration/multi-exes/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/cabal.project @@ -0,0 +1,1 @@ +packages: ./a/ ./b/ diff --git a/test/integration/multi-exes/hie.yaml b/test/integration/multi-exes/hie.yaml new file mode 100644 --- /dev/null +++ b/test/integration/multi-exes/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "all" diff --git a/test/integration/multi-mains/app/Foo.hs b/test/integration/multi-mains/app/Foo.hs new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/app/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +main = putStrLn "The bad main" diff --git a/test/integration/multi-mains/app/Main.hs b/test/integration/multi-mains/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Foo + +main :: IO () +main = Foo.main diff --git a/test/integration/multi-mains/cabal.project b/test/integration/multi-mains/cabal.project new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/test/integration/multi-mains/hie.yaml b/test/integration/multi-mains/hie.yaml new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "all" diff --git a/test/integration/multi-mains/multi-mains.cabal b/test/integration/multi-mains/multi-mains.cabal new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/multi-mains.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.8 +name: multi-mains +version: 0.1.0.0 +build-type: Simple + +executable multi-mains + main-is: Main.hs + other-modules: Foo + build-depends: base + hs-source-dirs: app + default-language: Haskell2010 + +executable multi-mains-bad + main-is: Main.hs + build-depends: base + hs-source-dirs: second + default-language: Haskell2010 diff --git a/test/integration/multi-mains/second/Main.hs b/test/integration/multi-mains/second/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/multi-mains/second/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "The right main" diff --git a/test/integration/repeat/Main.hs b/test/integration/repeat/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/repeat/Main.hs @@ -0,0 +1,5 @@ +module Main where +main :: IO () +main = do + let x = repeat "hello" + print ("hello world", x) diff --git a/test/integration/simple/Main.hs b/test/integration/simple/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/simple/Main.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where +import Control.Exception +import System.Environment +main :: IO () +main = do + args <- getArgs + putStrLn "hello" + print args + fail "CATCH ME" `catch` (\(_::SomeException) -> putStrLn "caught it") + putStrLn "goodbye" + return () diff --git a/test/integration/simple2/Main.hs b/test/integration/simple2/Main.hs new file mode 100644 --- /dev/null +++ b/test/integration/simple2/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import System.Environment + +data Pair = Pair (String, String) String + +data Depth = Depth String Depth | OK + +main = do + args <- getArgs + putStrLn $ showPair (Pair ("abcdasdf","ef") (show args)) + putStrLn $ showDepth (Depth "d=1" (Depth "d=2" (Depth "d=3" (Depth "d=4" (Depth "d=5" (Depth "d=6" OK)))))) + +showPair p = case p of + Pair x y -> + case x of + (a, b) -> a ++ b ++ y + +showDepth p = case p of + OK -> "OK" + Depth s d -> s ++ ";" ++ showDepth d +