haskell-debugger 0.5.0.0 → 0.6.0.0

raw patch · 15 files changed

+700/−131 lines, 15 filesdep +haskelinedep +optparse-applicativedep ~prettyprinterdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: haskeline, optparse-applicative

Dependency ranges changed: prettyprinter, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• haskell-debugger.cabal +17/−8
• haskell-debugger/GHC/Debugger.hs +10/−3
• haskell-debugger/GHC/Debugger/Breakpoint.hs +2/−1
• haskell-debugger/GHC/Debugger/Evaluation.hs +48/−10
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +2/−2
• haskell-debugger/GHC/Debugger/Logger.hs +119/−0
• haskell-debugger/GHC/Debugger/Session.hs +73/−6
• hdb/Development/Debug/Adapter.hs +1/−0
• hdb/Development/Debug/Adapter/Evaluation.hs +7/−4
• hdb/Development/Debug/Adapter/Flags.hs +19/−6
• hdb/Development/Debug/Adapter/Init.hs +25/−9
• hdb/Development/Debug/Adapter/Logger.hs +0/−67
• hdb/Development/Debug/Interactive.hs +250/−0
• hdb/Main.hs +116/−15

@@ -1,5 +1,16 @@ # Revision history for haskell-debugger +## 0.6.0.0 -- 2025-09-10++* Improve unit handling and fix running when `main` functions exist across different units+    * Add interactive home unit id+    * The entry file determines which of the `main`s to run.+* Add proper option parsing+* Add preview version of `hdb cli` interactive mode, as an alternative to DAP server+    * Experimental and incomplete+* Fix: output uncaught exceptions to stderr+* Fix: output eval completed result to console+ ## 0.5.0.0 -- 2025-08-26  * Compatibility with GHC 9.14

@@ -1,13 +1,13 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.5.0.0+version:            0.6.0.0 synopsis:     A step-through machine-interface debugger for GHC Haskell  description:        The GHC debugger package provides a standalone executable                     called @hdb@ which can be used to step-through Haskell                     programs and can act as a Debug Adapter Protocol (DAP)-                    server in the @--server@ mode for debugging Haskell+                    server in the @server@ mode for debugging Haskell                     programs.                     .                     The Debug Adapter is implemented on top of the@@ -49,8 +49,9 @@ library     import:           warnings     exposed-modules:  GHC.Debugger,-                      GHC.Debugger.Evaluation,                       GHC.Debugger.Breakpoint,+                      GHC.Debugger.Evaluation,+                      GHC.Debugger.Logger,                       GHC.Debugger.Stopped,                       GHC.Debugger.Stopped.Variables,                       GHC.Debugger.Utils,@@ -79,7 +80,12 @@                       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.18+                      hie-bios >= 0.15 && < 0.18,+                      -- Logger dependencies+                      time >= 1.14 && < 2,+                      prettyprinter >= 1.7.1 && < 2,+                      text >= 2.1 && < 2.3,+                      co-log-core >= 0.3.2.5 && < 0.4,      hs-source-dirs:   haskell-debugger     default-language: Haskell2010@@ -94,29 +100,32 @@                       Development.Debug.Adapter.Evaluation,                       Development.Debug.Adapter.Init,                       Development.Debug.Adapter.Interface,-                      Development.Debug.Adapter.Logger,                       Development.Debug.Adapter.Output,                       Development.Debug.Adapter.Exit,                       Development.Debug.Adapter.Handles,-                      Development.Debug.Adapter+                      Development.Debug.Adapter,+                      Development.Debug.Interactive     build-depends:         base, ghc,         exceptions, aeson, bytestring,         containers, filepath,         process, mtl, unix,-        prettyprinter >= 1.7.1 && < 2,          haskell-debugger,         hie-bios,         co-log-core >= 0.3.2.5 && < 0.4,         implicit-hie ^>=0.1.4.0,         transformers >= 0.6 && < 0.7,+        -- Logger dependencies+        prettyprinter, -        time >= 1.15 && < 2,         directory >= 1.3.9 && < 1.4,         async >= 2.2.5 && < 2.3,         text >= 2.1 && < 2.3,         dap >= 0.2 && < 1,++        haskeline >= 0.8 && < 1,+        optparse-applicative >= 0.18 && < 0.20     hs-source-dirs:   hdb     default-language: GHC2021     default-extensions: CPP

@@ -13,14 +13,15 @@ import GHC.Debugger.Monad import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages+import GHC.Debugger.Logger  -------------------------------------------------------------------------------- -- * Executing commands --------------------------------------------------------------------------------  -- | Execute the given debugger command in the current 'Debugger' session-execute :: Command -> Debugger Response-execute = \case+execute :: Recorder (WithSeverity DebuggerLog) -> Command -> Debugger Response+execute recorder = \case   ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing   ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp)   SetBreakpoint bp -> DidSetBreakpoint <$> setBreakpoint bp BreakpointEnabled@@ -44,8 +45,14 @@   DoSingleStep -> DidStep <$> doSingleStep   DoStepOut -> DidStep <$> doStepOut   DoStepLocal -> DidStep <$> doLocalStep-  DebugExecution { entryPoint, runArgs } -> DidExec <$> debugExecution entryPoint runArgs+  DebugExecution { entryPoint, entryFile, runArgs } -> DidExec <$> debugExecution (cmapWithSev EvalLog recorder) entryFile entryPoint runArgs   TerminateProcess -> liftIO $ do     -- Terminate!     exitWith ExitSuccess +data DebuggerLog+  = EvalLog EvalLog++instance Pretty DebuggerLog where+  pretty = \ case+    EvalLog msg -> pretty msg

@@ -21,6 +21,7 @@ import GHC.Utils.Outputable as GHC  import GHC.Debugger.Monad+import GHC.Debugger.Session import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages @@ -135,5 +136,5 @@     -- option is OFF and bp is ON (i.e. XOR)     breakOn = bp_status /= BreakpointDisabled     didChange = gopt opt dflags `xor` breakOn-  GHC.setInteractiveDynFlags $ dflags `ch_opt` opt+  setInteractiveDebuggerDynFlags $ dflags `ch_opt` opt   return (BreakFoundNoLoc didChange)

@@ -1,19 +1,32 @@-{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,-   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,-   TypeApplications, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} module GHC.Debugger.Evaluation where  import Control.Monad.IO.Class import Control.Monad.Catch+import qualified Data.List as List import Data.Maybe+import System.FilePath+import qualified Prettyprinter as Pretty  import GHC 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.Monad as GHC import GHC.Driver.Env as GHC-import GHC.Driver.Monad import GHC.Runtime.Debugger.Breakpoints as GHC+import qualified GHC.Unit.Module.ModSummary as GHC import GHC.ByteCode.Breakpoints import GHC.Types.Name.Occurrence (mkVarOccFS) import GHC.Types.Name.Reader as RdrName (mkOrig)@@ -25,20 +38,38 @@ import GHC.Debugger.Monad import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages+import GHC.Debugger.Logger +data EvalLog+  = LogEvalModule GHC.Module++instance Pretty EvalLog where+  pretty = \ case+    LogEvalModule modl -> "Eval Module Context:" Pretty.<+> pretty (GHC.showSDocUnsafe (ppr modl))+ -------------------------------------------------------------------------------- -- * Evaluation --------------------------------------------------------------------------------  -- | Run a program with debugging enabled-debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult-debugExecution entry args = do+debugExecution :: Recorder (WithSeverity EvalLog) -> FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution recorder entryFile entry args = do    -- consider always using :trace like ghci-dap to always have a stacktrace?   -- better solution could involve profiling stack traces or from IPE info?+  modSummaryOfEntryFile <- findUnitIdOfEntryFile entryFile+  let modOfEntryFile = GHC.ms_mod modSummaryOfEntryFile+      unitIdOfEntryFile = GHC.ms_unitid modSummaryOfEntryFile -  (entryExp, exOpts) <- case entry of+  let+    evalModule = mkModule (RealUnit (Definite unitIdOfEntryFile))+                                         (moduleName modOfEntryFile) +  logWith recorder Info $ LogEvalModule evalModule+  old_context <- GHC.getContext+  GHC.setContext [GHC.IIModule evalModule]++  (entryExp, exOpts) <- case entry of     MainEntry nm -> do       let prog = fromMaybe "main" nm       -- the wrapper is equivalent to GHCi's `:main arg1 arg2 arg3`@@ -53,11 +84,12 @@       -- be "\"some\"" "\"things\"".       return (fn ++ " " ++ unwords args, GHC.execOptions) -  GHC.execStmt entryExp exOpts >>= handleExecResult-+  exec_res <- GHC.execStmt entryExp exOpts+  GHC.setContext old_context -- restore context after running `main`+  handleExecResult exec_res   where     -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run-    mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue+    mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue     mkEvalWrapper progname' args' =       runInternal $ GHC.compileParsedExprRemote       $ evalWrapper' `GHC.mkHsApp` nlHsString progname'@@ -82,6 +114,12 @@               `gopt_set` Opt_ImplicitImportQualified           ) +    findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary+    findUnitIdOfEntryFile fp = do+      modSums <- getAllLoadedModules+      case List.find ((Just fp ==) . fmap normalise . GHC.ml_hs_file . GHC.ms_location ) modSums of+        Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp+        Just summary -> pure summary  -- | Resume execution of the stopped debuggee program doContinue :: Debugger EvalResult

@@ -73,13 +73,13 @@   -- When the @'EntryPoint'@ is @'Main'@, @'runArgs'@ are set as process   -- invocation arguments (as in @argv@) rather than passed directly as a   -- Haskell function arguments.-  | DebugExecution { entryPoint :: EntryPoint, runArgs :: [String] }+  | 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 }+data EntryPoint = MainEntry { mainName :: Maybe String } | FunctionEntry { fnName :: String }   deriving (Show, Generic)  -- | A breakpoint can be set/removed on functions by name, or in modules by

@@ -0,0 +1,119 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++-- | Simple Logger API using co-log style loggers+module GHC.Debugger.Logger (+  -- * The core Logger type+  Recorder,+  logWith,+  -- * Log messages+  Pretty(..),+  -- * For simpler usage+  Colog.LogAction (..),+  toCologAction,+  fromCologAction,+  -- * Severity+  Severity (..),+  WithSeverity (..),+  cmap,+  cmapIO,+  cmapWithSev,++  -- * Pretty printing of logs+  renderPrettyWithSeverity,+  renderWithSeverity,+  renderPretty,+  renderSeverity,+  renderWithTimestamp,++  -- Re-exports+  module Data.Functor.Contravariant,+) where++import GHC.Stack++import Control.Monad.IO.Class+import Control.Monad ((>=>))++import Colog.Core (Severity(..), WithSeverity(..))+import qualified Colog.Core as Colog+import Data.Functor.Contravariant (Contravariant (contramap))+import Data.Text (Text)+import qualified Data.Text as T+import Prettyprinter+import Prettyprinter.Render.Text (renderStrict)+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)++newtype Recorder msg = Recorder+  { logger_ :: forall m. (MonadIO m) => msg -> m () }++instance Contravariant Recorder where+  contramap f Recorder{ logger_ } =+    Recorder+      { logger_ = logger_ . f }++instance Semigroup (Recorder msg) where+  (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =+    Recorder+      { logger_ = \msg -> logger_1 msg >> logger_2 msg }++instance Monoid (Recorder msg) where+  mempty =+    Recorder+      { logger_ = \_ -> pure () }++logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m ()+logWith (Recorder logger_) sev msg = logger_ $ WithSeverity msg sev++cmap :: (a -> b) -> Recorder b -> Recorder a+cmap = contramap++cmapWithSev :: (a -> b) -> Recorder (WithSeverity b) -> Recorder (WithSeverity a)+cmapWithSev f = contramap (fmap f)++cmapIO :: (a -> IO b) -> Recorder b -> Recorder a+cmapIO f Recorder{ logger_ } =+  Recorder+    { logger_ = (liftIO . f) >=> logger_ }++renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text+renderPrettyWithSeverity =+  renderWithSeverity renderPretty++renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text+renderWithSeverity f msgWithSev =+  renderSeverity (getSeverity msgWithSev) <> " " <> f (getMsg msgWithSev)++renderPretty :: Pretty a => a -> Text+renderPretty a =+  let+    docToText = renderStrict . layoutPretty defaultLayoutOptions+  in+    docToText (pretty a)++renderWithTimestamp :: Text -> IO Text+renderWithTimestamp msg = do+  t <- getCurrentTime+  let timeStamp = utcTimeToText t+  pure $ "[" <> timeStamp <> "]" <> msg+  where+    utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime++renderSeverity :: Severity -> Text+renderSeverity = \ case+  Debug -> "[DEBUG]"+  Info -> "[INFO]"+  Warning -> "[WARNING]"+  Error -> "[ERROR]"++toCologAction :: (MonadIO m, HasCallStack) => Recorder msg -> Colog.LogAction m msg+toCologAction (Recorder logger_) = Colog.LogAction $ \msg -> do+    logger_ msg++fromCologAction :: (HasCallStack) => Colog.LogAction IO msg -> Recorder msg+fromCologAction (Colog.LogAction logger_) = Recorder $ \msg -> do+    liftIO $ logger_ msg

@@ -12,6 +12,10 @@   toGhcTarget,   CacheDirs(..),   getCacheDirs,+  -- * Debugger's Interactive Home Unit+  interactiveGhcDebuggerUnitId,+  getInteractiveDebuggerDynFlags,+  setInteractiveDebuggerDynFlags,   -- * DynFlags modifications   setWorkingDirectory,   setCacheDirs,@@ -114,8 +118,9 @@   GHC.setTargets (fmap toGhcTarget targetDetails)  -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's.-createUnitEnvFromFlags :: NonEmpty.NonEmpty DynFlags -> IO HomeUnitGraph-createUnitEnvFromFlags unitDflags = do+-- 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 @@ -123,8 +128,23 @@     emptyHpt <- emptyHomePackageTable     pure (homeUnitId_ dflags, newInternalUnitEnv dflags emptyHpt)) unitDflags -  pure $ unitEnv_new (Map.fromList (NonEmpty.toList unitEnvList))+  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 (interactiveHomeUnit : unitEnvList))+ -- | Given a set of 'DynFlags', set up the 'UnitEnv' and 'HomeUnitEnv' for this -- 'HscEnv'. -- We assume the 'HscEnv' is "empty", e.g. wasn't already used to compile@@ -133,7 +153,7 @@ initHomeUnitEnv unitDflags env = do   let dflags0         = hsc_dflags env   -- additionally, set checked dflags so we don't lose fixes-  initial_home_graph <- createUnitEnvFromFlags (dflags0 NonEmpty.:| unitDflags)+  initial_home_graph <- createUnitEnvFromFlags dflags0 unitDflags   let home_units = unitEnv_keys initial_home_graph   home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do     let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv@@ -151,12 +171,12 @@       , homeUnitEnv_home_unit = Just home_unit       } -  let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) 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    = homeUnitId_ dflags0+        , ue_current_unit    = interactiveGhcDebuggerUnitId         , ue_module_graph    = ue_module_graph (hsc_unit_env env)         , ue_eps             = ue_eps (hsc_unit_env env)         }@@ -273,6 +293,53 @@     -- Create a unique folder per set of different GHC options, assuming that each different set of     -- GHC options will create incompatible interface files.     opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)++-- ----------------------------------------------------------------------------+-- The Interactive DynFlags+-- ----------------------------------------------------------------------------++interactiveGhcDebuggerUnit :: Unit+interactiveGhcDebuggerUnit = stringToUnit "interactiveGhcDebugger"++interactiveGhcDebuggerUnitId :: UnitId+interactiveGhcDebuggerUnitId = toUnitId interactiveGhcDebuggerUnit++getInteractiveDebuggerDynFlags :: GhcMonad m => m DynFlags+getInteractiveDebuggerDynFlags = do+  env <- getSession+  pure $ ue_unitFlags interactiveGhcDebuggerUnitId (hsc_unit_env env)++-- | Set the interactive 'DynFlags' for the haskell-debugger session.+-- We manage a separate home unit for the interactive 'DynFlags'.+-- The invariant is that 'DynFlags' found in 'InteractiveContext' *must* be+-- the same 'DynFlags' as the ones found in 'interactiveGhcDebuggerUnitId' in+-- the 'HomeUnitEnv'+-- This function upholds this invariant.+--+-- Always prefer this, over 'setInteractiveDynFlags'.+setInteractiveDebuggerDynFlags :: GhcMonad m => DynFlags -> m ()+setInteractiveDebuggerDynFlags dflags = do+  env <- getSession+  norm_dflags <- GHC.normaliseInteractiveDynFlags (hsc_logger env) dflags+  env' <- GHC.initialiseInteractiveDynFlags norm_dflags env+  -- Make sure the 'InteractiveContext' and 'interactiveGhcDebuggerUnitId' have exactly+  -- the same 'DynFlags'+  let newEnv =+        if homeUnitId_ (hsc_dflags env') == interactiveGhcDebuggerUnitId+          then hscSetFlags norm_dflags env'+          else+            let+              unit_env = hsc_unit_env env'+            in env'+                { hsc_unit_env = unit_env+                    { ue_home_unit_graph =+                        updateUnitFlags+                          interactiveGhcDebuggerUnitId+                          (const norm_dflags)+                          (ue_home_unit_graph unit_env)+                    }+                }+  setSession newEnv  -- ---------------------------------------------------------------------------- -- Modification of DynFlags

@@ -29,6 +29,7 @@ #else       , breakpointMap :: Map.Map GHC.BreakpointId BreakpointSet #endif+      , entryFile :: FilePath       , entryPoint :: String       , entryArgs :: [String]       , projectRoot :: FilePath

@@ -22,11 +22,11 @@ --  [ ] Consider using Output events for debuggee evaluation. startExecution :: DebugAdaptor EvalResult startExecution = do-  DAS{entryPoint, entryArgs} <- getDebugSession+  DAS{entryFile, entryPoint, entryArgs} <- getDebugSession   let entry         | entryPoint == "main" = MainEntry Nothing         | otherwise            = FunctionEntry entryPoint-  DidExec er <- sendSync DebugExecution{entryPoint = entry, runArgs = entryArgs}+  DidExec er <- sendSync DebugExecution{entryPoint = entry, entryFile, runArgs = entryArgs}   return er  --------------------------------------------------------------------------------@@ -76,10 +76,13 @@     Output.console (T.pack e)     sendTerminatedEvent defaultTerminatedEvent     sendExitedEvent (ExitedEvent 43)-  EvalCompleted{} -> do+  EvalCompleted{resultVal, resultType} -> do+    Output.console (T.pack $ "Evaluation returned: " ++ resultVal ++ " :: " ++ resultType)     sendTerminatedEvent defaultTerminatedEvent     sendExitedEvent (ExitedEvent 0)-  EvalException{} -> do+  EvalException{resultVal, resultType} -> do+    Output.stderr (T.pack $ "Uncaught exception of type " ++ resultType ++ " was thrown!")+    Output.stderr (T.pack resultVal)     sendTerminatedEvent defaultTerminatedEvent     sendExitedEvent (ExitedEvent 42)   EvalStopped {breakId = Nothing} ->

@@ -21,6 +21,7 @@ import System.FilePath import System.IO.Error import Text.ParserCombinators.ReadP (readP_to_S)+import Prettyprinter  import qualified HIE.Bios as HIE import qualified HIE.Bios.Config as Config@@ -31,8 +32,17 @@ import qualified Hie.Locate as Implicit import qualified Hie.Yaml as Implicit -import Development.Debug.Adapter.Logger+import GHC.Debugger.Logger +data FlagsLog+  = HieBiosLog HIE.Log+  | LogCradle (HIE.Cradle Void)++instance Pretty FlagsLog where+  pretty = \ case+    HieBiosLog msg -> pretty msg+    LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl+ -- | Flags inferred by @hie-bios@ to invoke GHC data HieBiosFlags = HieBiosFlags       { ghcInvocation :: [String]@@ -46,18 +56,21 @@       -- root of the cradle, but in some sub-directory.       } -hieBiosCradle :: LogAction IO (WithSeverity HIE.Log) {-^ Logger -}+hieBiosCradle :: Recorder (WithSeverity FlagsLog) {-^ Logger -}               -> FilePath {-^ Project root -}               -> FilePath {-^ Entry file relative to root -}               -> IO (Either String (HIE.Cradle Void)) hieBiosCradle logger root relTarget = runExceptT $ do   let target = root </> relTarget   explicitCradle <- HIE.findCradle target & liftIO-  cradle <- maybe (loadImplicitCradle logger target)-                  (HIE.loadCradle logger) explicitCradle & liftIO+  cradle <- maybe (loadImplicitCradle hieBiosLogger target)+                  (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO+  logWith logger Info $ LogCradle cradle   pure cradle+  where+    hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger -hieBiosRuntimeGhcVersion :: LogAction IO (WithSeverity HIE.Log)+hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog)                          -> HIE.Cradle Void                          -> IO (Either String Version) hieBiosRuntimeGhcVersion _logger cradle = runExceptT $ do@@ -67,7 +80,7 @@     Just ver -> pure ver  -- | Make 'HieBiosFlags' from the given target file-hieBiosFlags :: LogAction IO (WithSeverity HIE.Log) {-^ Logger -}+hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -}              -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}              -> FilePath {-^ Project root -}              -> FilePath {-^ Entry file relative to root -}

@@ -24,11 +24,12 @@ import Data.Aeson as Aeson import GHC.Generics import System.Directory+import System.FilePath  import Development.Debug.Adapter import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Flags-import Development.Debug.Adapter.Logger+import GHC.Debugger.Logger import qualified Development.Debug.Adapter.Output as Output  import qualified GHC.Debugger as Debugger@@ -40,6 +41,19 @@ import Development.Debug.Adapter.Handles  --------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------++data InitLog+  = DebuggerLog Debugger.DebuggerLog+  | FlagsLog FlagsLog++instance Pretty InitLog where+  pretty = \ case+    DebuggerLog msg -> pretty msg+    FlagsLog msg -> pretty msg++-------------------------------------------------------------------------------- -- * Client -------------------------------------------------------------------------------- @@ -69,11 +83,11 @@ -- | Initialize debugger -- -- Returns @True@ if successful.-initDebugger :: LogAction IO (WithSeverity T.Text) -> LaunchArgs -> DebugAdaptor Bool-initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile, entryPoint, entryArgs, extraGhcArgs} = do+initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> DebugAdaptor Bool+initDebugger l LaunchArgs{__sessionId, projectRoot, entryFile = entryFile, entryPoint, entryArgs, extraGhcArgs} = do   syncRequests  <- liftIO newEmptyMVar   syncResponses <- liftIO newEmptyMVar-  let hieBiosLogger = cmapWithSev renderPretty l+  let hieBiosLogger = cmapWithSev FlagsLog l   cradle <- liftIO (hieBiosCradle hieBiosLogger projectRoot entryFile) >>=     \ case       Left e ->@@ -123,8 +137,9 @@        finished_init <- liftIO $ newEmptyMVar -      registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{..}-        [ debuggerThread finished_init writeDebuggerOutput projectRoot flags extraGhcArgs entryFile defaultRunConf syncRequests syncResponses+      let absEntryFile = normalise $ projectRoot </> entryFile+      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         , stderrCaptureThread@@ -177,7 +192,8 @@ --    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 :: MVar (Either String ()) -- ^ To signal when initialization is complete.+debuggerThread :: Recorder (WithSeverity InitLog)+               -> MVar (Either String ()) -- ^ To signal when initialization is complete.                -> Handle          -- ^ The write end of a handle for debug compiler output                -> FilePath        -- ^ Working directory for GHC session                -> HieBiosFlags    -- ^ GHC Invocation flags@@ -189,7 +205,7 @@                -> (DebugAdaptorCont () -> IO ())                -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'.                -> IO ()-debuggerThread finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do+debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do    let finalGhcInvocation = ghcInvocation ++ extraGhcArgs @@ -210,7 +226,7 @@          forever $ do           req <- takeMVar requests & liftIO-          resp <- (Debugger.execute req <&> Right)+          resp <- (Debugger.execute (cmapWithSev DebuggerLog recorder) req <&> Right)                     `catch` \(e :: SomeException) ->                         pure (Left (displayExceptionWithContext e))           either bad reply resp

@@ -1,67 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}---- | Simple Logger API using co-log style loggers-module Development.Debug.Adapter.Logger (-  LogAction (..),-  Severity (..),-  WithSeverity (..),-  cmap,-  cmapIO,-  cmapWithSev,--  -- * Pretty printing of logs-  renderPrettyWithSeverity,-  renderWithSeverity,-  renderPretty,-  renderSeverity,-  renderWithTimestamp,-) where--import Control.Monad.IO.Class-import Control.Monad ((>=>))-import Colog.Core (LogAction (..), Severity (..), WithSeverity (..))-import Colog.Core.Action (cmap)-import Data.Text (Text)-import qualified Data.Text as T-import Prettyprinter-import Prettyprinter.Render.Text (renderStrict)-import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)--cmapWithSev :: (a -> b) -> LogAction m (WithSeverity b) -> LogAction m (WithSeverity a)-cmapWithSev f = cmap (fmap f)--cmapIO :: MonadIO m => (a -> IO b) -> LogAction m b -> LogAction m a-cmapIO f LogAction{ unLogAction } =-  LogAction-    { unLogAction = (liftIO . f) >=> unLogAction }--renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text-renderPrettyWithSeverity =-  renderWithSeverity renderPretty--renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text-renderWithSeverity f msgWithSev =-  renderSeverity (getSeverity msgWithSev) <> " " <> f (getMsg msgWithSev)--renderPretty :: Pretty a => a -> Text-renderPretty a =-  let-    docToText = renderStrict . layoutPretty defaultLayoutOptions-  in-    docToText (pretty a)--renderWithTimestamp :: Text -> IO Text-renderWithTimestamp msg = do-  t <- getCurrentTime-  let timeStamp = utcTimeToText t-  pure $ "[" <> timeStamp <> "]" <> msg-  where-    utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime--renderSeverity :: Severity -> Text-renderSeverity = \ case-  Debug -> "[DEBUG]"-  Info -> "[INFO]"-  Warning -> "[WARNING]"-  Error -> "[ERROR]"

@@ -0,0 +1,250 @@+{-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards #-}+module Development.Debug.Interactive where++import System.IO+import System.Exit+import System.Directory+import System.Console.Haskeline+import System.Console.Haskeline.Completion+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.RWS+import Options.Applicative+import Options.Applicative.BashCompletion++import Development.Debug.Adapter.Flags  -- use different namespace for common things+import Development.Debug.Adapter.Handles++import GHC.Debugger.Logger+import GHC.Debugger.Interface.Messages+import GHC.Debugger.Monad+import GHC.Debugger++-- | Interactive debugging monad+type InteractiveDM a = InputT (RWST (FilePath{-entry file-},String{-entry point-}, [String]{-run args-}) ()+                                (Maybe Command{-last cmd-}) Debugger) a++data InteractiveLog+  = DebuggerLog DebuggerLog+  | FlagsLog FlagsLog++instance Pretty InteractiveLog where+  pretty = \ case+    DebuggerLog msg -> pretty msg+    FlagsLog msg -> pretty msg++-- | Run it+runIDM :: String   -- ^ entryPoint+       -> FilePath -- ^ entryFile+       -> [String] -- ^ entryArgs+       -> [String] -- ^ extraGhcArgs+       -> InteractiveDM a+       -> IO a+runIDM entryPoint entryFile entryArgs extraGhcArgs act = do+  projectRoot <- getCurrentDirectory+  l           <- handleLogger stdout+  let+    loggerWithSev = cmap renderPrettyWithSeverity (fromCologAction l)+  let hieBiosLogger = cmapWithSev FlagsLog loggerWithSev+  cradle <- hieBiosCradle hieBiosLogger projectRoot entryFile >>=+    \case+      Left e -> exitWithMsg e+      Right c -> pure c+  mflags <- hieBiosFlags hieBiosLogger cradle projectRoot entryFile+  case mflags of+    Left e -> exitWithMsg e+    Right HieBiosFlags{..} -> do+      let defaultRunConf = RunDebuggerSettings+            { supportsANSIStyling = True+            , supportsANSIHyperlinks = False+            }+      let finalGhcInvocation = ghcInvocation ++ extraGhcArgs+      runDebugger stdout rootDir componentDir libdir units finalGhcInvocation entryFile defaultRunConf $+        fmap fst $+          evalRWST (runInputT (setComplete noCompletion defaultSettings) act)+                   (entryFile, entryPoint, entryArgs) Nothing+  where+    exitWithMsg str = do+      putStrLn str+      exitWith (ExitFailure 33)++  --   completeF = completeWordWithPrev Nothing filenameWordBreakChars $+  --     \(reverse -> previous) word -> do+  --       let comp_words = words previous ++ [word]+  --           comp_cword = length comp_words+  --       case execParserPure parserPrefs cmdParserInfo+  --           ("--bash-completion-index":show comp_cword:+  --             concat (zipWith (\fl a -> [fl, show a]) (repeat "--bash-completion-word") comp_words)) of+  --         CompletionInvoked CompletionResult{execCompletion} ->+  --           map simpleCompletion . words <$> liftIO (execCompletion "")+  --         _ -> return []++-- | Run the interactive command-line debugger+debugInteractive :: Recorder (WithSeverity InteractiveLog) -> InteractiveDM ()+debugInteractive recorder = withInterrupt loop+  where+    debugRec = cmapWithSev DebuggerLog recorder+    loop = handleInterrupt loop $ do+      minput <- getInputLine "(hdb) "+      case minput of+        Nothing -> outputStrLn "Exiting..." >> liftIO (exitWith ExitSuccess)+        Just "" -> do+          lift get >>= \case+            Nothing -> return ()+            Just (cmd :: Command) -> do+              out <- lift . lift $ execute debugRec cmd -- repeat last command+              printResponse debugRec out+        Just input -> do+          mcmd <- parseCmd input+          lift $ put mcmd+          case mcmd of+            Nothing -> return ()+            Just cmd -> do+              out <- lift . lift $ execute debugRec cmd+              printResponse debugRec out+      loop++--------------------------------------------------------------------------------+-- Printing+--------------------------------------------------------------------------------++printResponse :: Recorder (WithSeverity DebuggerLog) -> Response -> InteractiveDM ()+printResponse recd = \case+  DidEval er -> outputStrLn $ show er+  DidSetBreakpoint bf       -> outputStrLn $ show bf+  DidRemoveBreakpoint bf    -> outputStrLn $ show bf+  DidGetBreakpoints mb_span -> outputStrLn $ show mb_span+  DidClearBreakpoints -> outputStrLn "Cleared all breakpoints."+  DidContinue er -> outputStrLn $ show er+  DidStep er -> printEvalResult recd er+  DidExec er -> outputStrLn $ show er+  GotStacktrace stackframes -> outputStrLn $ show stackframes+  GotScopes scopeinfos -> outputStrLn $ show scopeinfos+  GotVariables vis -> outputStrLn $ show vis -- (Either VarInfo [VarInfo])+  Aborted str -> outputStrLn ("Aborted: " ++ str)+  Initialised -> pure ()++printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM ()+printEvalResult recd EvalStopped{breakId} = do+  out <- lift . lift $ execute recd GetScopes+  printResponse recd out+printEvalResult _ er = outputStrLn $ show er++--------------------------------------------------------------------------------+-- Command parser+--------------------------------------------------------------------------------++breakpointParser :: Parser Breakpoint+breakpointParser =+  ( ModuleBreak+  <$> argument str+      ( metavar "PATH" -- todo: accept module breaks using module name+     <> help "Path to module to break at" )+  <*> argument auto+      ( metavar "LINE_NUM"+     <> help "The line number to break at" )+  <*> optional (argument auto+      ( metavar "COLUMN_NUM"+     <> help "The column number to break at" ))+  )+  <|>+  ( FunctionBreak+    <$> option str+      ( long "name"+     <> short 'n'+     <> metavar "FUNCTION_NAME"+     <> help "Set a breakpoint using the function name" )+  )+  <|>+  ( flag' OnExceptionsBreak ( long "exceptions" )+  )+  <|>+  ( flag' OnUncaughtExceptionsBreak ( long "error" )+  )++runParser :: FilePath -> String -> [String] -> Parser Command+runParser entryFile entryPoint entryArgs =+  -- --entry <name> with some args+  -- (DebugExecution <$> parseEntry <*> parseSomeArgs)+  -- --entry <name> without any args+  -- <|> (DebugExecution <$> parseEntry <*> pure [])+  -- just some args+  (DebugExecution (mkEntry entryPoint) entryFile <$> parseSomeArgs)+  -- just "run"+  <|> (pure $ DebugExecution (mkEntry entryPoint) entryFile entryArgs)+  where+    parseEntry =+      fmap mkEntry $+      option str+        ( long "entry"+        <> short 'e'+        <> metavar "FUNCTION_NAME"+        <> help "Run with this entry point"+        )+    parseSomeArgs =+      some ( argument str+        ( metavar "ARGS" <> help "Arguments to pass to the entry point. If empty, the arguments given at the debugger invocation are used." ) )+    mkEntry entry+      | entry == "main" = MainEntry Nothing+      | otherwise = FunctionEntry entryPoint++-- | Combined parser for 'Command'+cmdParser :: FilePath -> String -> [String] -> Parser Command+cmdParser entryFile entryPoint entryArgs = hsubparser+  ( Options.Applicative.command "break"+    ( info (SetBreakpoint <$> breakpointParser)+      ( progDesc "Set a breakpoint" ) )+  <>+    Options.Applicative.command "delete"+    ( info (DelBreakpoint <$> breakpointParser)+      ( progDesc "Delete a breakpoint" ) )+  <>+    Options.Applicative.command "run"+    ( info (runParser entryFile entryPoint entryArgs)+      ( progDesc "Run the debuggee" ) )+  <>+    Options.Applicative.command "next"+    ( info (pure DoStepLocal)+      ( progDesc "Step over to the next line" ) )+  <>+    Options.Applicative.command "step"+    ( info (pure DoSingleStep)+      ( progDesc "Step-in to the next immediate location" ) )+  <>+    Options.Applicative.command "finish"+    ( info (pure DoStepOut)+      ( progDesc "Step-out of the current function into the caller/its continuation" ) )+  <>+    Options.Applicative.command "continue"+    ( info (pure DoContinue)+      ( progDesc "Continue executing from the current breakpoint" ) )+  <>+    Options.Applicative.command "print"+    ( info (DoEval . unwords <$> many (argument str ( metavar "EXPRESSION"+     <> help "Expression to evaluate in the current context" )))+      ( progDesc "Evaluate an expression in the current context" ) )+  )++-- | Main parser info+cmdParserInfo :: FilePath -> String -> [String] -> ParserInfo Command+cmdParserInfo entryFile entryPoint entryArgs = info (cmdParser entryFile entryPoint entryArgs)+  ( fullDesc )++-- | Parse command line arguments+parseCmd :: String -> InteractiveDM (Maybe Command)+parseCmd input = do+  (entryFile, entryPoint, entryArgs) <- lift ask+  let+    res = execParserPure+     parserPrefs+     (cmdParserInfo entryFile entryPoint entryArgs)+     (words input)+   in case res of+    Success x ->+      return (Just x)+    Failure bad ->+      let (msg, _exit) = renderFailure bad "(hdb)"+       in outputStrLn msg >> pure Nothing+    _ -> outputStrLn "Unsupported command parsing mode" >> pure Nothing++parserPrefs = prefs (disambiguate <> showHelpOnError <> showHelpOnEmpty)

@@ -14,33 +14,126 @@ import Development.Debug.Adapter.Evaluation import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles-import Development.Debug.Adapter.Logger+import GHC.Debugger.Logger import Development.Debug.Adapter +import Development.Debug.Interactive+ import System.IO (hSetBuffering, BufferMode(LineBuffering))-import DAP.Log+import qualified DAP.Log as DAP import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD+import Options.Applicative hiding (command)+import qualified Options.Applicative +-- | The options `hdb` is invoked in the command line with+data HdbOptions+  -- | @server --port <port>@+  = HdbDAPServer+    { port :: Int+    }+  -- | @[--entry-point=<entryPoint>] [--extra-ghc-args="<args>"] [<entryFile>] -- [<entryArgs>]@+  | HdbCLI+    { entryPoint :: String+    , entryFile :: FilePath+    , entryArgs :: [String]+    , extraGhcArgs :: [String]+    }++--------------------------------------------------------------------------------+-- Options parser+--------------------------------------------------------------------------------++-- | Parser for HdbDAPServer options+serverParser :: Parser HdbOptions+serverParser = HdbDAPServer+  <$> option auto+      ( long "port"+     <> short 'p'+     <> metavar "PORT"+     <> help "DAP server port" )++-- | Parser for HdbCLI options+cliParser :: Parser HdbOptions+cliParser = HdbCLI+  <$> strOption+      ( long "entry-point"+     <> short 'e'+     <> metavar "ENTRY_POINT"+     <> value "main"+     <> help "The name of the function that is called to start execution (default: main)" )+  <*> argument str+      ( metavar "ENTRY_FILE"+     <> help "The relative path from the project root to the file with the entry point for execution" )+  <*> many+        ( argument str+          ( metavar "ENTRY_ARGS..."+         <> help "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."+          )+        )+  <*> option (words <$> str)+      ( long "extra-ghc-args"+     <> metavar "GHC_ARGS"+     <> value []+     <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" )++-- | Combined parser for HdbOptions+hdbOptionsParser :: Parser HdbOptions+hdbOptionsParser = hsubparser+  ( Options.Applicative.command "server"+    ( info serverParser+      ( progDesc "Start the Haskell debugger in DAP server mode" ) )+ <> Options.Applicative.command "cli"+    ( info cliParser+      ( progDesc "Debug a Haskell program in CLI mode" ) )+  )+  <|> cliParser  -- Default to CLI mode if no subcommand++-- | Main parser info+hdbParserInfo :: ParserInfo HdbOptions+hdbParserInfo = info (hdbOptionsParser <**> helper)+  ( fullDesc+ <> header "Haskell debugger supporting both CLI and DAP modes" )++-- | Parse command line arguments+parseHdbOptions :: IO HdbOptions+parseHdbOptions = customExecParser+  defaultPrefs{prefShowHelpOnError = True, prefShowHelpOnEmpty = True}+  hdbParserInfo++--------------------------------------------------------------------------------+ defaultStdoutForwardingAction :: T.Text -> IO () defaultStdoutForwardingAction line = do   T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> line)  main :: IO () main = do-  port <- getArgs >>= \case-            ["--server", "--port", readMaybe -> Just p] -> return p-            _ -> fail "usage: --server --port <port>"-  config <- getConfig port-  withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do-    hSetBuffering realStdout LineBuffering-    l <- handleLogger realStdout-    let-      timeStampLogger = cmapIO renderWithTimestamp l-      loggerWithSev = cmap (renderWithSeverity id) timeStampLogger-    runDAPServerWithLogger (cmap renderDAPLog timeStampLogger) config (talk loggerWithSev)+  hdbOpts <- parseHdbOptions+  case hdbOpts of+    HdbDAPServer{port} -> do+      config <- getConfig port+      withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do+        hSetBuffering realStdout LineBuffering+        l <- handleLogger realStdout+        let+          timeStampLogger :: Recorder T.Text+          timeStampLogger = cmapIO renderWithTimestamp (fromCologAction l)+          loggerWithSev :: Recorder (WithSeverity MainLog)+          loggerWithSev = cmap renderPrettyWithSeverity timeStampLogger+        runDAPServerWithLogger (toCologAction $ cmap DAP.renderDAPLog timeStampLogger) config (talk loggerWithSev)+    HdbCLI{..} -> do+      l <- handleLogger stdout+      let+        timeStampLogger :: Recorder T.Text+        timeStampLogger = cmapIO renderWithTimestamp (fromCologAction l)+        loggerWithSev :: Recorder (WithSeverity MainLog)+        loggerWithSev = cmap renderPrettyWithSeverity timeStampLogger+      runIDM entryPoint entryFile entryArgs extraGhcArgs $+        debugInteractive (cmapWithSev InteractiveLog loggerWithSev) + -- | Fetch config from environment, fallback to sane defaults getConfig :: Int -> IO ServerConfig getConfig port = do@@ -90,10 +183,18 @@ -- * Talk -------------------------------------------------------------------------------- +data MainLog+  = InitLog InitLog+  | InteractiveLog InteractiveLog++instance Pretty MainLog where+  pretty = \ case+    InitLog msg -> pretty msg+ -- | Main function where requests are received and Events + Responses are returned. -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function.-talk :: LogAction IO (WithSeverity T.Text) -> Command -> DebugAdaptor ()+talk :: Recorder (WithSeverity MainLog) -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- talk l = \ case   CommandInitialize -> do@@ -101,7 +202,7 @@     sendInitializeResponse --------------------------------------------------------------------------------   CommandLaunch -> do-    success <- initDebugger l =<< getArguments+    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