Merge branch 'master' into wip/debug-instance

Author: meipp

.github/workflows/debugger.yaml

@@ -1,4 +1,4 @@
-on: [push, workflow_call, pull_request]
+on: [workflow_call, pull_request]
 
 name: Debugger CI
 jobs:

README.md

@@ -12,47 +12,40 @@ first major release is ready.
 
 # Installation
 
+Please find up to date installation instructions on the
+[project homepage](https://well-typed.github.io/haskell-debugger/)!
+
 > [!WARNING]
-> `hdb` is only supported by the latest nightly GHC version.
+> `hdb` can currently be compiled with the 9.14 alpha pre-releases or with a nightly version
 > The first release it will be compatible with is GHC 9.14.
 
 To install and use the debugger, you need the executable `hdb`
-and the VSCode extension `haskell-debugger-extension`.
+and the VSCode extension [Haskell Debugger](https://marketplace.visualstudio.com/items?itemName=Well-Typed.haskell-debugger-extension).
 
 Since `hdb` implements the [Debug Adapter Protocol
 (DAP)](https://microsoft.github.io/debug-adapter-protocol/), it also supports
 debugging with tools such as vim, neovim, or emacs -- as long as a DAP client is
 installed and the `launch` arguments for `hdb` configured.
 
-To build, install, and run `hdb` you currently need a nightly
-version of GHC in PATH. You can get one using
-[GHCup](https://ghcup.readthedocs.io/en/latest/guide/), or [building from source](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation):
+To run the debugger, the same version of GHC which compiled it needs to be in
+PATH. Make sure the DAP client knows this. For instance, to launch VSCode with a specific GHC use:
 ```
-ghcup config add-release-channel https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
-ghcup install ghc latest-nightly 
-PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH cabal install haskell-debugger:hdb --enable-executable-dynamic --allow-newer=ghc-bignum,containers,time,ghc
+PATH=/path/to/ghc-dir:$PATH code /path/to/proj
 ```
 
-To run the debugger, the same nightly version of GHC needs to be in PATH. Make
-sure the DAP client knows this. For instance, to launch VSCode use:
-```
-PATH=$(dirname $(ghcup whereis ghc latest-nightly)):$PATH code /path/to/proj
-```
-Currently, to install the debugger extension, download the `.vsix` file from the
-GitHub release artifacts and drag and drop it to the extensions side panel. In
-the future we will release it on the marketplace.
-
 # Usage
 
 To use the debugger in VSCode, select the debugger tab, select Haskell Debugger,
 and create a `launch.json` file by clicking the debugger settings icon (next to
-the green run button).
+the green run button). Now, it is also supported to just Run a file which
+contains a `main` function.
 
 The `launch.json` file contains some settings about the debugger session here.
 Namely:
 
 | Setting | Description |
 | --- | --- |
+| `projectRoot`  | the full path to the project root. this is typically `${workspaceFolder}`, a value which is interpolated by the editor with the actual path                                           |
 | `entryFile`    | the relative path from the project root to the file with the entry point for execution                                                                                                |
 | `entryPoint`   | the name of the function that is called to start execution                                                                                                                            |
 | `entryArgs`    | the arguments passed to the `entryPoint`. If the `entryPoint` is `main`, these arguments are passed as environment arguments (as in `getArgs`) rather than direct function arguments. |
@@ -63,8 +56,6 @@ Change them accordingly.
 To run the debugger, simply hit the green run button.
 See the Features section below for what is currently supported.
 
-Note: Listing global variables is only supported in GHC versions newer than May 6, 2025
-
 # Related Work
 
 `hdb` is inspired by the original
@@ -136,7 +127,6 @@ nix-build
 
 ```
 cd test/integration-tests
-nix-shell
 make GHC=/path/to/recent/ghc \
      DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/recent/ghc exe:hdb)
 ```

haskell-debugger/GHC/Debugger/Stopped/Variables.hs

@@ -8,8 +8,11 @@ import Control.Monad.Reader
 
 import GHC
 import GHC.Types.FieldLabel
+import GHC.Types.Id.Info
+import GHC.Types.Var
 import GHC.Runtime.Eval
 import GHC.Core.DataCon
+import GHC.Core.TyCo.Rep
 import qualified GHC.Runtime.Debugger as GHCD
 import qualified GHC.Runtime.Heap.Inspect as GHCI
 
@@ -23,10 +26,17 @@ import GHC.Debugger.Utils
 -- | '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 = \case
-  t@(AConLike c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables
-  t@(ATyCon c)   -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables
-  t@(ACoAxiom c) -> VarInfo <$> display c <*> display t <*> display t <*> pure False <*> pure NoVariables
+tyThingToVarInfo 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
+  AnId i
+    | DataConWrapId data_con <- idDetails i
+    -- Newtype cons don't have a runtime representation, so we can't obtain
+    -- terms! Simply print the newtype cons like we do data cons.
+    -- See Note [Newtype workers]
+    , isNewTyCon (dataConTyCon data_con)
+    -> VarInfo <$> display data_con <*> display t <*> display t <*> pure False <*> pure NoVariables
   AnId i -> do
     let key = FromId i
     term <- obtainTerm key
@@ -73,11 +83,21 @@ termToVarInfo :: TermKey -> Term -> Debugger VarInfo
 termToVarInfo key term0 = do
   -- Make a VarInfo for a term
   let
-    isThunk
-     | Suspension{} <- term0 = True
-     | otherwise = False
     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
+
+    isThunk = if not isFn then
+      case term0 of
+        Suspension{} -> True
+        _ -> False
+      else False
+
   term <- if not isThunk && isBoringTy ty
             then forceTerm key term0 -- make sure that if it's an evaluated boring term then it is /fully/ evaluated.
             else pure term0
@@ -90,13 +110,15 @@ termToVarInfo key term0 = do
       | isBoringTy ty = t
       | otherwise     = case t of
          Term{}                    -> t{subTerms = []}
-         NewtypeWrap{wrapped_term} -> t{wrapped_term = termHead wrapped_term}
          _                         -> t
   varName <- display key
   varType <- display ty
-  varValue <- do
-    _ <- onDebugInstance term ty
-    display =<< GHCD.showTerm (termHead term)
+  -- Pass type as value for functions since actual value is useless
+  varValue <- if isFn
+    then pure $ "<fn> :: " ++ varType
+    else do
+      _ <- onDebugInstance term ty
+      display =<< GHCD.showTerm (termHead term)
   -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)
 
   -- The VarReference allows user to expand variable structure and inspect its value.

hdb/Development/Debug/Adapter/Exit.hs

@@ -71,7 +71,7 @@ exitCleanupWithMsg
   -- killing the output thread with @destroyDebugSession@)
   -> String
   -- ^ Error message, logged with notification
-  -> DebugAdaptor ()
+  -> DebugAdaptor a
 exitCleanupWithMsg final_handle msg = do
   destroyDebugSession -- kill all session threads (including the output thread)
   do                  -- flush buffer and get all pending output from GHC

hdb/Development/Debug/Adapter/Init.hs

@@ -4,15 +4,19 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | TODO: This module should be called Launch.
 module Development.Debug.Adapter.Init where
 
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified System.Process as P
+import Control.Monad.Except
+import Control.Monad.Trans
 import Data.Function
 import Data.Functor
+import Data.Maybe
 import Data.Version (Version(..), showVersion, makeVersion)
 import Control.Monad.IO.Class
 import System.IO
@@ -62,16 +66,16 @@ data LaunchArgs
   = LaunchArgs
   { __sessionId :: Maybe String
     -- ^ SessionID, set by VSCode client
-  , projectRoot :: FilePath
+  , projectRoot :: Maybe FilePath
     -- ^ Absolute path to the project root
-  , entryFile :: FilePath
+  , entryFile :: Maybe FilePath
     -- ^ The file with the entry point e.g. @app/Main.hs@
-  , entryPoint :: String
+  , entryPoint :: Maybe String
     -- ^ Either @main@ or a function name
-  , entryArgs :: [String]
+  , entryArgs :: Maybe [String]
     -- ^ The arguments to either set as environment arguments when @entryPoint = "main"@
     -- or function arguments otherwise.
-  , extraGhcArgs :: [String]
+  , extraGhcArgs :: Maybe [String]
     -- ^ Additional arguments to pass to the GHC invocation inferred by hie-bios for this project
   } deriving stock (Show, Eq, Generic)
     deriving anyclass FromJSON
@@ -80,39 +84,53 @@ data LaunchArgs
 -- * Launch Debugger
 --------------------------------------------------------------------------------
 
+-- | Exception type for when initialization fails
+newtype InitFailed = InitFailed String deriving Show
+
 -- | Initialize debugger
 --
--- Returns @True@ if successful.
-initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> DebugAdaptor Bool
-initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile = entryFile, entryPoint, entryArgs, extraGhcArgs} = do
+-- Returns @()@ if successful, throws @InitFailed@ otherwise
+initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()
+initDebugger l LaunchArgs{ __sessionId
+                         , projectRoot = givenRoot
+                         , entryFile = entryFileMaybe
+                         , entryPoint = fromMaybe "main" -> entryPoint
+                         , entryArgs  = fromMaybe [] -> entryArgs
+                         , extraGhcArgs = fromMaybe [] -> extraGhcArgs
+                         } = do
   syncRequests  <- liftIO newEmptyMVar
   syncResponses <- liftIO newEmptyMVar
+
+  entryFile <- case entryFileMaybe of
+    Nothing -> throwError $ InitFailed "Missing \"entryFile\" key in debugger configuration"
+    Just ef -> pure ef
+
+  projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot
+
   let hieBiosLogger = cmapWithSev FlagsLog l
   cradle <- liftIO (hieBiosCradle hieBiosLogger projectRoot entryFile) >>=
     \ case
-      Left e ->
-        exitWithMsg e
-
+      Left e  -> throwError $ InitFailed e
       Right c -> pure c
 
-  Output.console $ T.pack "Checking GHC version against debugger version..."
+  lift $ Output.console $ T.pack "Checking GHC version against debugger version..."
   -- GHC is found in PATH (by hie-bios as well).
   actualVersion <- liftIO (hieBiosRuntimeGhcVersion hieBiosLogger cradle) >>=
     \ case
-      Left e ->
-        exitWithMsg e
+      Left e  -> throwError $ InitFailed e
       Right c -> pure c
   -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):
   when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do
-    exitWithMsg $ "Aborting...! The GHC version must be the same which " ++
-                    "ghc-debug-adapter was compiled against (" ++
-                      showVersion compileTimeGhcWithoutPatchVersion++
-                        "). Instead, got " ++ (showVersion actualVersion) ++ "."
+    throwError $ InitFailed $
+      "Aborting...! The GHC version must be the same which " ++
+        "ghc-debug-adapter was compiled against (" ++
+          showVersion compileTimeGhcWithoutPatchVersion++
+            "). Instead, got " ++ (showVersion actualVersion) ++ "."
 
-  Output.console $ T.pack "Discovering session flags with hie-bios..."
+  lift $ Output.console $ T.pack "Discovering session flags with hie-bios..."
   mflags <- liftIO (hieBiosFlags hieBiosLogger cradle projectRoot entryFile)
   case mflags of
-    Left e -> exitWithMsg e
+    Left e -> throwError $ InitFailed e
     Right flags -> do
 
       let nextFreshBreakpointId = 0
@@ -138,7 +156,7 @@ initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile = entryFile, entry
       finished_init <- liftIO $ newEmptyMVar
 
       let absEntryFile = normalise $ projectRoot </> entryFile
-      registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..}
+      lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..}
         [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses
         , handleDebuggerOutput readDebuggerOutput
         , stdoutCaptureThread
@@ -147,14 +165,13 @@ initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile = entryFile, entry
 
       -- Do not return until the initialization is finished
       liftIO (takeMVar finished_init) >>= \case
-        Right () -> return True
+        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.
-          exitCleanupWithMsg readDebuggerOutput e
-          return False
+          throwError $ InitFailed e
 
 -- | This thread captures stdout from the debugger and sends it to the client.
 -- NOTE, redirecting the stdout handle is a process-global operation. So this thread

hdb/Main.hs

@@ -5,6 +5,8 @@ import System.Environment
 import Data.Maybe
 import Data.Version
 import Text.Read
+import Control.Monad.Except
+import Control.Monad.IO.Class
 
 import DAP
 
@@ -209,14 +211,19 @@ talk l = \ case
     sendInitializeResponse
 --------------------------------------------------------------------------------
   CommandLaunch -> do
-    success <- initDebugger (cmapWithSev InitLog l) =<< getArguments
-    if success then do
-      sendLaunchResponse   -- ack
-      sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session
-    else
-      sendError ErrorMessageCancelled Nothing
+    launch_args <- getArguments
+    merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) launch_args
+    case merror of
+      Right () -> do
+        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
 --------------------------------------------------------------------------------
-  CommandAttach -> undefined
+  CommandAttach -> do
+    sendErrorResponse (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing
+    exitCleanly
 --------------------------------------------------------------------------------
   CommandBreakpointLocations       -> commandBreakpointLocations
   CommandSetBreakpoints            -> commandSetBreakpoints

test/integration-tests/data/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

test/integration-tests/data/T64/Main.hs

@@ -0,0 +1,5 @@
+newtype MyIntTy = MyIntCon Int
+
+main :: IO ()
+main = pure ()
+

test/integration-tests/data/T71/Main.hs

@@ -0,0 +1,2 @@
+main = do
+  putStrLn "T71 is running!"