haskell-debugger 0.8.0.0 → 0.9.0.0

raw patch · 26 files changed

+1488/−598 lines, 26 filesdep +aeson-prettydep +networkdep +network-rundep ~aesondep ~asyncdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-pretty, network, network-run, random, regex, tasty, tasty-golden, tasty-hunit, temporary, unordered-containers

Dependency ranges changed: aeson, async, bytestring, containers, dap, filepath, process, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• haskell-debugger.cabal +34/−6
• haskell-debugger/GHC/Debugger.hs +0/−1
• haskell-debugger/GHC/Debugger/Breakpoint.hs +4/−18
• haskell-debugger/GHC/Debugger/Evaluation.hs +6/−7
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +0/−27
• haskell-debugger/GHC/Debugger/Logger.hs +13/−2
• haskell-debugger/GHC/Debugger/Monad.hs +0/−26
• haskell-debugger/GHC/Debugger/Runtime.hs +21/−15
• haskell-debugger/GHC/Debugger/Session.hs +6/−4
• haskell-debugger/GHC/Debugger/Stopped.hs +0/−8
• haskell-debugger/GHC/Debugger/Stopped/Variables.hs +3/−0
• hdb/Development/Debug/Adapter.hs +8/−4
• hdb/Development/Debug/Adapter/Breakpoints.hs +0/−17
• hdb/Development/Debug/Adapter/Flags.hs +0/−281
• hdb/Development/Debug/Adapter/Init.hs +53/−53
• hdb/Development/Debug/Adapter/Proxy.hs +161/−0
• hdb/Development/Debug/Interactive.hs +26/−20
• hdb/Development/Debug/Options.hs +42/−0
• hdb/Development/Debug/Options/Parser.hs +117/−0
• hdb/Development/Debug/Session/Setup.hs +344/−0
• hdb/Main.hs +96/−108
• test/haskell/Main.hs +118/−1
• test/haskell/Test/DAP.hs +122/−0
• test/haskell/Test/DAP/RunInTerminal.hs +279/−0
• test/haskell/Test/Utils.hs +25/−0

@@ -1,8 +1,18 @@ # Revision history for haskell-debugger +## 0.8.0.0 -- 2025-09-19++* Allow defaults for all settings except `entryFile` and return a proper error in that case+* Fix bug that crashed debugger when attempting to load newtype constructor closure+* Fix bug that broke displaying newtype variables+* (Vscode) Allow the debugger to be run without a launch.json file+* Don't display functions as a forceable thunk, instead just the type+* Add `--version` flag+ ## 0.7.0.0 -- 2025-09-10  * Fix line buffering of debuggee output (thus, stepping through a print line, will indeed print it to the console now).+    * In fact, this was only caused by not building with `--enable-executable-dynamic`  ## 0.6.0.0 -- 2025-09-10 

@@ -1,6 +1,6 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.8.0.0+version:            0.9.0.0 synopsis:     A step-through machine-interface debugger for GHC Haskell @@ -93,8 +93,7 @@ executable hdb     import:           warnings     main-is:          Main.hs-    other-modules:    Development.Debug.Adapter.Flags,-                      Development.Debug.Adapter.Breakpoints,+    other-modules:    Development.Debug.Adapter.Breakpoints,                       Development.Debug.Adapter.Stepping,                       Development.Debug.Adapter.Stopped,                       Development.Debug.Adapter.Evaluation,@@ -104,7 +103,16 @@                       Development.Debug.Adapter.Exit,                       Development.Debug.Adapter.Handles,                       Development.Debug.Adapter,++                      Development.Debug.Adapter.Proxy,+                       Development.Debug.Interactive,++                      Development.Debug.Session.Setup,++                      Development.Debug.Options,+                      Development.Debug.Options.Parser,+                       Paths_haskell_debugger     autogen-modules:  Paths_haskell_debugger     build-depends:@@ -112,6 +120,7 @@         exceptions, aeson, bytestring,         containers, filepath,         process, mtl, unix,+        unordered-containers >= 0.2.19 && < 0.3,          haskell-debugger,         hie-bios,@@ -122,9 +131,11 @@         prettyprinter,          directory >= 1.3.9 && < 1.4,+        network >= 3.2.8,+        network-run >= 0.4.4,         async >= 2.2.5 && < 2.3,         text >= 2.1 && < 2.3,-        dap >= 0.2 && < 1,+        dap >= 0.3 && < 1,          haskeline >= 0.8 && < 1,         optparse-applicative >= 0.18 && < 0.20@@ -136,11 +147,28 @@ test-suite haskell-debugger-test     import:           warnings     default-language: Haskell2010-    -- other-modules:     -- other-extensions:     type:             exitcode-stdio-1.0     hs-source-dirs:   test/haskell/     main-is:          Main.hs+    other-modules:    Test.DAP.RunInTerminal, Test.DAP, Test.Utils     build-depends:         base >=4.14,-        haskell-debugger+        haskell-debugger,+        bytestring, text,+        containers,+        filepath,+        process,+        temporary >= 1.3,++        unordered-containers,+        aeson-pretty >= 0.8.10, async >= 2.2.5,+        dap, network, aeson, network-run,+        random >= 1.3.1,++        tasty >= 1.5.3,+        tasty-golden >= 2.3.5,+        tasty-hunit >= 0.10.2,+        regex >= 1.1+    build-tool-depends: haskell-debugger:hdb+    ghc-options: -threaded

@@ -5,7 +5,6 @@  import System.Exit import Control.Monad.IO.Class-import GHC.Types.Name.Occurrence (sizeOccEnv)  import GHC.Debugger.Breakpoint import GHC.Debugger.Evaluation

@@ -10,7 +10,6 @@ import Data.Bits (xor)  import GHC-import GHC.Types.Name.Occurrence (sizeOccEnv) import GHC.ByteCode.Breakpoints import GHC.Utils.Error (logOutput) import GHC.Driver.DynFlags as GHC@@ -76,42 +75,29 @@         Just (bix, spn) -> do           let bid = BreakpointId { bi_tick_mod = ms_mod modl                                  , bi_tick_index = bix }-#if MIN_VERSION_ghc(9,14,2)           (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind-#else-          changed <- registerBreakpoint bid bp_status ModuleBreakpointKind-#endif           return $ BreakFound             { changed = changed             , sourceSpan = realSrcSpanToSourceSpan spn-#if MIN_VERSION_ghc(9,14,2)             , breakId = ibis-#else-            , breakId = bid-#endif             } setBreakpoint FunctionBreak{function} bp_status = do   logger <- getLogger   resolveFunctionBreakpoint function >>= \case-    Left e -> error (showPprUnsafe e)+    Left e -> do+      liftIO $ logOutput logger $ text $+        "Failed to resolve function breakpoint " ++ function ++ ".\n" ++ showPprUnsafe e ++ "\nIgnoring..."+      return BreakNotFound     Right (modl, mod_info, fun_str) -> do       let modBreaks = GHC.modInfoModBreaks mod_info           applyBreak (bix, spn) = do             let bid = BreakpointId { bi_tick_mod = modl                                    , bi_tick_index = bix }-#if MIN_VERSION_ghc(9,14,2)             (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind-#else-            changed <- registerBreakpoint bid bp_status FunctionBreakpointKind-#endif             return $ BreakFound               { changed = changed               , sourceSpan = realSrcSpanToSourceSpan spn-#if MIN_VERSION_ghc(9,14,2)               , breakId = ibis-#else-              , breakId = bid-#endif               }       case maybe [] (findBreakForBind fun_str . imodBreaks_modBreaks) modBreaks of         []  -> do

@@ -11,11 +11,13 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Debugger.Evaluation where +import GHC.Utils.Outputable import Control.Monad.IO.Class import Control.Monad.Catch import qualified Data.List as List import Data.Maybe import System.FilePath+import System.Directory import qualified Prettyprinter as Pretty  import GHC@@ -27,7 +29,6 @@ import GHC.Driver.Env as GHC 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) import GHC.Utils.Outputable as GHC@@ -116,9 +117,11 @@      findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary     findUnitIdOfEntryFile fp = do+      afp <- normalise <$> liftIO (makeAbsolute fp)       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+      let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location+      case List.find ((Just afp ==) . normalisedModLoc) modSums of+        Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums)         Just summary -> pure summary  -- | Resume execution of the stopped debuggee program@@ -196,11 +199,7 @@       -- TODO: force the exception to display string with Backtrace?       return EvalStopped{breakId = Nothing}     ExecBreak {breakNames = _, breakPointId} ->-#if MIN_VERSION_ghc(9,14,2)       return EvalStopped{breakId = breakPointId}-#else-      return EvalStopped{breakId = toBreakpointId <$> breakPointId}-#endif  -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'. inspectName :: Name -> Debugger (Maybe VarInfo)

@@ -210,11 +210,7 @@   = BreakFound     { changed :: !Bool     -- ^ Did the status of the found breakpoint change?-#if MIN_VERSION_ghc(9,14,2)     , breakId :: [GHC.InternalBreakpointId]-#else-    , breakId :: GHC.BreakpointId-#endif     -- ^ Internal breakpoint identifier (module + ix) (TODO: Don't expose GHC)     , sourceSpan :: SourceSpan     -- ^ Source span for interface@@ -233,11 +229,7 @@ data EvalResult   = EvalCompleted { resultVal :: String, resultType :: String }   | EvalException { resultVal :: String, resultType :: String }-#if MIN_VERSION_ghc(9,14,2)   | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }-#else-  | EvalStopped   { breakId :: Maybe GHC.BreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} }-#endif   -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped.   | EvalAbortedWith String   deriving (Show, Generic)@@ -291,8 +283,6 @@ instance FromJSON VarInfo instance FromJSON VarFields -#if MIN_VERSION_ghc(9,14,2)- instance Show GHC.InternalBreakpointId where   show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix @@ -306,20 +296,3 @@   parseJSON = withObject "InternalBreakpointId" $ \v -> GHC.InternalBreakpointId         <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name"))         <*> v .: "ix"-#else--instance Show GHC.BreakpointId where-  show (GHC.BreakpointId m ix) = "BreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix--instance ToJSON GHC.BreakpointId where-  toJSON (GHC.BreakpointId (Module unit mn) ix) =-    object [ "module_name" .= moduleNameString mn-           , "module_unit" .= unitString unit-           , "ix" .= ix-           ]-instance FromJSON GHC.BreakpointId where-  parseJSON = withObject "BreakpointId" $ \v -> GHC.BreakpointId-        <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name"))-        <*> v .: "ix"--#endif

@@ -22,6 +22,9 @@   cmap,   cmapIO,   cmapWithSev,+  -- * Verbosity+  Verbosity(..),+  applyVerbosity,    -- * Pretty printing of logs   renderPrettyWithSeverity,@@ -39,7 +42,7 @@ import Control.Monad.IO.Class import Control.Monad ((>=>)) -import Colog.Core (Severity(..), WithSeverity(..))+import Colog.Core (Severity(..), WithSeverity(..), filterBySeverity) import qualified Colog.Core as Colog import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Text (Text)@@ -66,8 +69,16 @@     Recorder       { logger_ = \_ -> pure () } +-- | Logging verbosity, where all Severities matching or exceeding the threshold are printed+newtype Verbosity = Verbosity { threshold :: Severity }++-- | Make this logger never report messages whose severity is below the given verbosity severity.+applyVerbosity :: Verbosity -> Recorder (WithSeverity a) -> Recorder (WithSeverity a)+applyVerbosity Verbosity{threshold} rc+  = fromCologAction $ filterBySeverity threshold getSeverity (toCologAction rc)+ logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m ()-logWith (Recorder logger_) sev msg = logger_ $ WithSeverity msg sev+logWith Recorder{logger_} sev msg = logger_ $ WithSeverity msg sev  cmap :: (a -> b) -> Recorder b -> Recorder a cmap = contramap

@@ -182,11 +182,7 @@ -- 'BreakpointStatus' being set. -- -- Returns @True@ when the breakpoint status is changed.-#if MIN_VERSION_ghc(9,14,2) registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger (Bool, [GHC.InternalBreakpointId])-#else-registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool-#endif registerBreakpoint bp@GHC.BreakpointId                     { GHC.bi_tick_mod = mod                     , GHC.bi_tick_index = bid } status kind = do@@ -194,13 +190,9 @@   -- Set breakpoint in GHC session   let breakpoint_count = breakpointStatusInt status   hsc_env <- GHC.getSession-#if MIN_VERSION_ghc(9,14,2)   internal_break_ids <- getInternalBreaksOf bp   forM_ internal_break_ids $ \ibi -> do     GHC.setupBreakpoint (hscInterp hsc_env) ibi breakpoint_count-#else-  GHC.setupBreakpoint (hscInterp hsc_env) bp breakpoint_count-#endif    -- Register breakpoint in Debugger state   brksRef <- asks activeBreakpoints@@ -240,21 +232,13 @@    -- no races since the debugger execution is run in a single thread   liftIO $ writeIORef brksRef newBrks-#if MIN_VERSION_ghc(9,14,2)   return (changed, internal_break_ids)-#else-  return changed-#endif   -- | Get a list with all currently active breakpoints on the given module (by path) -- -- If the path argument is @Nothing@, get all active function breakpoints instead-#if MIN_VERSION_ghc(9,14,2) getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.InternalBreakpointId]-#else-getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.BreakpointId]-#endif getActiveBreakpoints mfile = do   m <- asks activeBreakpoints >>= liftIO . readIORef   case mfile of@@ -262,11 +246,7 @@       mms <- getModuleByPath file       case mms of         Right ms ->-#if MIN_VERSION_ghc(9,14,2)           concat <$> mapM getInternalBreaksOf-#else-          return-#endif             [ GHC.BreakpointId mod bix             | (mod, im) <- moduleEnvToList m             , mod == ms_mod ms@@ -277,11 +257,7 @@           displayWarnings [e]           return []     Nothing -> do-#if MIN_VERSION_ghc(9,14,2)       concat <$> mapM getInternalBreaksOf-#else-      return-#endif         [ GHC.BreakpointId mod bix         | (mod, im) <- moduleEnvToList m         , (bix, (status, kind)) <- IM.assocs im@@ -452,7 +428,6 @@  -------------------------------------------------------------------------------- -#if MIN_VERSION_ghc(9,14,2) -- | Find all the internal breakpoints that use the given source-level breakpoint id getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId] getInternalBreaksOf bi = do@@ -460,4 +435,3 @@   return $     fromMaybe [] {- still not found after refresh -} $       lookupBreakpointOccurrences bs bi-#endif

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-}+{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns #-} module GHC.Debugger.Runtime where  import Data.IORef@@ -9,6 +9,7 @@ import GHC.Types.FieldLabel import GHC.Tc.Utils.TcType import GHC.Runtime.Eval+import GHC.Runtime.Heap.Inspect  import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache@@ -21,8 +22,9 @@ -- scratch and stored in the cache. obtainTerm :: TermKey -> Debugger Term obtainTerm key = do-  tc_ref <- asks termCache-  tc     <- liftIO $ readIORef tc_ref+  hsc_env <- getSession+  tc_ref  <- asks termCache+  tc      <- liftIO $ readIORef tc_ref   case lookupTermCache key tc of     -- cache miss: reconstruct, then store.     Nothing ->@@ -37,17 +39,8 @@         getTerm = \case           FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i           FromPath k pf -> do-            term <- getTerm k >>= \case-              -- When the key points to a Suspension, the real thing should-              -- already be forced. It's just that the shallow depth meant we-              -- returned a Suspension nonetheless while recursing in `getTerm`.-              t@Suspension{} -> do-                t' <- seqTerm t-                -- update term cache with intermediate values?-                -- insertTermCache k t'-                return t'-              t -> return t-            return $ case term of+            term <- getTerm k+            liftIO $ expandTerm hsc_env $ case term of               Term{dc=Right dc, subTerms} -> case pf of                 PositionalIndex ix -> subTerms !! (ix-1)                 LabeledField fl    ->@@ -59,11 +52,24 @@               _ -> error "Unexpected term for the given TermKey"        in do         term <- getTerm key-        liftIO $ writeIORef tc_ref (insertTermCache key term tc)+        liftIO $ modifyIORef tc_ref (insertTermCache key term)         return term      -- cache hit     Just hit -> return hit++-- | Before returning a 'Term' we want to expand its heap representation up to the 'defaultDepth'+--+-- For 'Id's, this is done by 'GHC.obtainTermFromId'. For other 'TermKey's this+-- function should be used+expandTerm :: HscEnv -> Term -> IO Term+expandTerm hsc_env term = case term of+  Term{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val+  (NewtypeWrap{}; RefWrap{}) -> do+    -- TODO: we don't do anything clever here yet+    return term+  -- For other terms there's no point in trying to expand+  (Suspension{}; Prim{}) -> return term  -- | A boring type is one for which we don't care about the structure and would -- rather see "whole" when being inspected. Strings and literals are a good

@@ -29,7 +29,6 @@ import qualified Crypto.Hash.SHA1                    as H import qualified Data.ByteString.Base16              as B16 import qualified Data.ByteString.Char8               as B-import Data.Function import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.List as L@@ -87,7 +86,9 @@         -- If we don't end up with a target for the current file in the end, then         -- we will report it as an error for that file         let abs_fp = rootDir </> cfp-        let special_target = mkSimpleTarget df abs_fp+        -- Canonicalize! Why? Because the targets we get from the cradle are normalised and if we don't normalise the "special target" then they aren't deduplicated properly.+        canon_fp <- liftIO $ Directory.canonicalizePath abs_fp+        let special_target = mkSimpleTarget df canon_fp         pure $ (df, special_target : targets) NonEmpty.:| []     where       initMulti unitArgFiles =@@ -96,10 +97,11 @@           initOne args       initOne this_opts = do         (dflags', targets') <- addCmdOpts this_opts dflags-        let targets = HIE.makeTargetsAbsolute root targets'-            root = case workingDirectory dflags' of+        let root = case workingDirectory dflags' of               Nothing   -> compRoot               Just wdir -> compRoot </> wdir+        root_canon <- liftIO $ Directory.canonicalizePath root+        let targets = HIE.makeTargetsAbsolute root_canon targets'         cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts         let dflags'' =               setWorkingDirectory root $

@@ -196,12 +196,8 @@         case GHC.resumeBreakpointId r of           Nothing -> return []           Just ibi -> do-#if MIN_VERSION_ghc(9,14,2)             curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>                           readIModBreaks (hsc_HUG hsc_env) ibi-#else-            let curr_modl = ibi_tick_mod ibi-#endif             things <- typeEnvElts <$> getTopEnv curr_modl             mapM (\tt -> do               nameStr <- display (getName tt)@@ -212,12 +208,8 @@         case GHC.resumeBreakpointId r of           Nothing -> return []           Just ibi -> do-#if MIN_VERSION_ghc(9,14,2)             curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$>                           readIModBreaks (hsc_HUG hsc_env) ibi-#else-            let curr_modl = ibi_tick_mod ibi-#endif             names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl             mapM (\n-> do               nameStr <- display n

@@ -43,6 +43,9 @@     termToVarInfo 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 = 

@@ -1,7 +1,9 @@ module Development.Debug.Adapter where  import Control.Concurrent.MVar+import Control.Concurrent.Chan import qualified Data.IntSet as IS+import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Text as T import System.FilePath@@ -24,15 +26,17 @@       { syncRequests :: MVar D.Command       , syncResponses :: MVar D.Response       , nextFreshBreakpointId :: !BreakpointId-#if MIN_VERSION_ghc(9,14,2)       , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet-#else-      , breakpointMap :: Map.Map GHC.BreakpointId BreakpointSet-#endif       , 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       }  type BreakpointId = Int

@@ -116,7 +116,6 @@     BreakFoundNoLoc _ch -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = True } ]     BreakFound _ch iid ss -> do       source <- fileToSource ss.file-#if MIN_VERSION_ghc(9,14,2)       bids <- mapM registerNewBreakpoint iid       pure $ map (\bid -> DAP.defaultBreakpoint         { DAP.breakpointVerified = True@@ -127,25 +126,9 @@         , DAP.breakpointEndColumn = Just ss.endCol         , DAP.breakpointId = Just bid         }) bids-#else-      bid <- registerNewBreakpoint iid-      pure [ DAP.defaultBreakpoint-        { DAP.breakpointVerified = True-        , DAP.breakpointSource = Just source-        , DAP.breakpointLine = Just ss.startLine-        , DAP.breakpointEndLine = Just ss.endLine-        , DAP.breakpointColumn = Just ss.startCol-        , DAP.breakpointEndColumn = Just ss.endCol-        , DAP.breakpointId = Just bid-        } ]-#endif  -- | Adds new BreakpointId for a givent StgPoint-#if MIN_VERSION_ghc(9,14,2) registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId-#else-registerNewBreakpoint :: GHC.BreakpointId -> DebugAdaptor BreakpointId-#endif registerNewBreakpoint breakpoint = do   bkpId <- getFreshBreakpointId   updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap}

@@ -1,281 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Development.Debug.Adapter.Flags where--import Control.Applicative ((<|>))-import Control.Exception (handleJust)-import Control.Monad-import Control.Monad.Except-import Control.Monad.IO.Class-import Control.Monad.Trans.Maybe-import Data.Bifunctor-import Data.Function-import Data.Functor ((<&>))-import Data.Maybe-import Data.Version-import Data.Void-import System.Directory hiding (findFile)-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-import qualified HIE.Bios.Cradle as HIE-import qualified HIE.Bios.Environment as HIE-import qualified HIE.Bios.Types as HIE-import qualified Hie.Cabal.Parser as Implicit-import qualified Hie.Locate as Implicit-import qualified Hie.Yaml as Implicit--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]-      , libdir :: FilePath-      , units :: [String]-      , rootDir :: FilePath-      -- ^ Root dir as reported by the 'Cradle'-      , componentDir :: FilePath-      -- ^ Root dir of the loaded 'ComponentOptions'.-      -- Important for multi-package cabal projects, as packages are not in the-      -- root of the cradle, but in some sub-directory.-      }--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 hieBiosLogger target)-                  (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO-  logWith logger Info $ LogCradle cradle-  pure cradle-  where-    hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger--hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog)-                         -> HIE.Cradle Void-                         -> IO (Either String Version)-hieBiosRuntimeGhcVersion _logger cradle = runExceptT $ do-  out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"-  case versionMaybe out of-    Nothing -> throwError $ "Failed to parse GHC version: " <> out-    Just ver -> pure ver---- | Make 'HieBiosFlags' from the given target file-hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -}-             -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}-             -> FilePath {-^ Project root -}-             -> FilePath {-^ Entry file relative to root -}-             -> IO (Either String HieBiosFlags)-hieBiosFlags _logger cradle root relTarget = runExceptT $ do-  let target = root </> relTarget-  libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"--  -- To determine the flags we MUST set the current directory to the root-  -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)-  -- (HIE.getCompilerOptions depends on CWD being the proper root dir)-  let compilerOpts = liftIO $ withCurrentDirectory root $-#if MIN_VERSION_hie_bios(0,14,0)-                          HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle-#else-                          HIE.getCompilerOptions target [] cradle-#endif-  componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"-#if __GLASGOW_HASKELL__ >= 913-  -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading-  -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.-  -- ["-fwrite-if-simplified-core"] ++-#endif--  let (units', flags') = extractUnits (HIE.componentOptions componentOpts)-  return HieBiosFlags-    { ghcInvocation = flags' ++ ghcDebuggerFlags-    , libdir = libdir-    , units  = units'-    , rootDir = HIE.cradleRootDir cradle-    , componentDir = HIE.componentRoot componentOpts-    }--unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a-unwrapCradleResult m = \case-  HIE.CradleNone      -> throwError $ "HIE.CradleNone\n" ++ m-  HIE.CradleFail err  -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m-  HIE.CradleSuccess x -> return x--extractUnits :: [String] -> ([String], [String])-extractUnits = go [] []-  where-    -- TODO: we should likely use the 'processCmdLineP' instead-    go units rest ("-unit" : x : xs) = go (x : units) rest xs-    go units rest (x : xs)           = go units (x : rest) xs-    go units rest []                 = (reverse units, reverse rest)---- | Flags specific to haskell-debugger to append to all GHC invocations.-ghcDebuggerFlags :: [String]-ghcDebuggerFlags =-  [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt-  ]----- ------------------------------------------------------------------------------- Utilities--- ------------------------------------------------------------------------------versionMaybe :: String -> Maybe Version-versionMaybe xs = case reverse $ readP_to_S parseVersion xs of-  [] -> Nothing-  (x:_) -> Just (fst x)---- ------------------------------------------------------------------------------- Implicit cradle discovery logic mirroring the one used by HLS.--- The code itself is copy-pasted from HLS.--- Obviously, we want to reuse the logic without having to depend on HLS.--- We should factor out a common sub-component from HLS and use it here as well.--- ------------------------------------------------------------------------------loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)-loadImplicitCradle l wfile = do-  is_dir <- doesDirectoryExist wfile-  let wdir | is_dir = wfile-           | otherwise = takeDirectory wfile-  cfg <- runMaybeT (implicitConfig wdir)-  case cfg of-    Just bc -> HIE.getCradle l absurd bc-    Nothing -> return $ HIE.defaultCradle l wdir---- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies-implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)-implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree-  where-  noDeps :: [FilePath]-  noDeps = []---inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)-inferCradleTree start_dir =-       maybeItsBios-   -- If we have both a config file (cabal.project/stack.yaml) and a work dir-   -- (dist-newstyle/.stack-work), prefer that-   <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))-   <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)-   -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal-   <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)-   -- If we have a stack.yaml, use stack-   <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)-   -- If we have a cabal file, use cabal-   <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)--  where-  maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir--  cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)---- | Generate a stack cradle given a filepath.------ Since we assume there was proof that this file belongs to a stack cradle--- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.--- We do not look for package.yaml, as we assume the corresponding .cabal has--- been generated already.------ We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then--- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to--- component names.-stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)-stackCradle fp = do-  pkgs <- Implicit.stackYamlPkgs fp-  pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs-  let yaml = fp </> "stack.yaml"-  pure $ (,fp) $ case pkgsWithComps of-    [] -> Config.Stack (Config.StackType Nothing (Just yaml))-    ps -> Config.StackMulti mempty $ do-      Implicit.Package n cs <- ps-      c <- cs-      let (prefix, comp) = Implicit.stackComponent n c-      pure (prefix, Config.StackType (Just comp) (Just yaml))---- | By default, we generate a simple cabal cradle which is equivalent to the--- following hie.yaml:------ @---   cradle:---     cabal:--- @------ Note, this only works reliable for reasonably modern cabal versions >= 3.2.-simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)-simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp)--cabalExecutable :: MaybeT IO FilePath-cabalExecutable = MaybeT $ findExecutable "cabal"--stackExecutable :: MaybeT IO FilePath-stackExecutable = MaybeT $ findExecutable "stack"--biosWorkDir :: FilePath -> MaybeT IO FilePath-biosWorkDir = findFileUpwards (".hie-bios" ==)--cabalWorkDir :: FilePath -> MaybeT IO ()-cabalWorkDir wdir = do-  check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")-  unless check $ fail "No dist-newstyle"--stackWorkDir :: FilePath -> MaybeT IO ()-stackWorkDir wdir = do-  check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")-  unless check $ fail "No .stack-work"--cabalConfigDir :: FilePath -> MaybeT IO FilePath-cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")--cabalFileDir :: FilePath -> MaybeT IO FilePath-cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")--stackConfigDir :: FilePath -> MaybeT IO FilePath-stackConfigDir = findFileUpwards isStack-  where-    isStack name = name == "stack.yaml"---- | Searches upwards for the first directory containing a file to match--- the predicate.-findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath-findFileUpwards p dir = do-  cnts <--    liftIO-    $ handleJust-        -- Catch permission errors-        (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)-        pure-        (findFile p dir)--  case cnts of-    [] | dir' == dir -> fail "No cabal files"-            | otherwise   -> findFileUpwards p dir'-    _ : _ -> return dir-  where dir' = takeDirectory dir---- | Sees if any file in the directory matches the predicate-findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]-findFile p dir = do-  b <- doesDirectoryExist dir-  if b then getFiles >>= filterM doesPredFileExist else return []-  where-    getFiles = filter p <$> getDirectoryContents dir-    doesPredFileExist file = doesFileExist $ dir </> file

@@ -9,16 +9,18 @@ -- | TODO: This module should be called Launch. module Development.Debug.Adapter.Init where +import GHC.IO.Handle+import System.Process+import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.IO as T+import qualified Data.Text.Encoding 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 import GHC.IO.Encoding import Control.Monad.Catch@@ -32,7 +34,6 @@  import Development.Debug.Adapter import Development.Debug.Adapter.Exit-import Development.Debug.Adapter.Flags import GHC.Debugger.Logger import qualified Development.Debug.Adapter.Output as Output @@ -43,6 +44,7 @@  import DAP import Development.Debug.Adapter.Handles+import Development.Debug.Session.Setup  -------------------------------------------------------------------------------- -- * Logging@@ -84,14 +86,15 @@ -- * Launch Debugger -------------------------------------------------------------------------------- --- | Exception type for when initialization fails+-- | Exception type for when hie-bios initialization fails newtype InitFailed = InitFailed String deriving Show  -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise-initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()-initDebugger l LaunchArgs{ __sessionId+initDebugger :: Recorder (WithSeverity InitLog) -> Bool -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()+initDebugger l supportsRunInTerminal+               LaunchArgs{ __sessionId                          , projectRoot = givenRoot                          , entryFile = entryFileMaybe                          , entryPoint = fromMaybe "main" -> entryPoint@@ -100,6 +103,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"@@ -108,31 +114,10 @@   projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot    let hieBiosLogger = cmapWithSev FlagsLog l-  cradle <- liftIO (hieBiosCradle hieBiosLogger projectRoot entryFile) >>=-    \ case-      Left e  -> throwError $ InitFailed e-      Right c -> pure c--  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  -> 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-    throwError $ InitFailed $-      "Aborting...! The GHC version must be the same which " ++-        "ghc-debug-adapter was compiled against (" ++-          showVersion compileTimeGhcWithoutPatchVersion++-            "). Instead, got " ++ (showVersion actualVersion) ++ "."--  lift $ Output.console $ T.pack "Discovering session flags with hie-bios..."-  mflags <- liftIO (hieBiosFlags hieBiosLogger cradle projectRoot entryFile)-  case mflags of-    Left e -> throwError $ InitFailed e-    Right flags -> do-+  liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case+    Left e              -> throwError $ InitFailed e+    Right (Left e)      -> lift       $ exitWithMsg e+    Right (Right flags) -> do       let nextFreshBreakpointId = 0           breakpointMap = mempty           defaultRunConf = Debugger.RunDebuggerSettings@@ -157,10 +142,12 @@        let absEntryFile = normalise $ projectRoot </> entryFile       lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..}-        [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses+        [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags+            extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses         , handleDebuggerOutput readDebuggerOutput-        , stdoutCaptureThread-        , stderrCaptureThread+        , stdinForwardThread  supportsRunInTerminal syncProxyIn+        , stdoutCaptureThread supportsRunInTerminal syncProxyOut+        , stderrCaptureThread supportsRunInTerminal syncProxyErr         ]        -- Do not return until the initialization is finished@@ -171,27 +158,52 @@           -- This can happen if compilation fails and the compiler exits cleanly.           --           -- Instead of signalInitialized, respond with error and exit.-          throwError $ InitFailed e+          lift $ exitCleanupWithMsg readDebuggerOutput e --- | This thread captures stdout from the debugger and sends it to the client.+-- | 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 debugger emits. Therefore you should never directly+-- will capture ANY stdout the debuggee emits. Therefore you should never directly -- write to stdout, but always write to the appropiate handle.-stdoutCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO ()-stdoutCaptureThread withAdaptor = do+stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdoutCaptureThread runInTerminal syncOut withAdaptor = do   withInterceptedStdout $ \_ interceptedStdout -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStdout+      when runInTerminal $+        writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")++      -- Always output to Debug Console       withAdaptor $ Output.stdout line  -- | Like 'stdoutCaptureThread' but for stderr-stderrCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO ()-stderrCaptureThread withAdaptor = do+stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stderrCaptureThread runInTerminal syncErr withAdaptor = do   withInterceptedStderr $ \_ interceptedStderr -> do     forever $ do       line <- liftIO $ T.hGetLine interceptedStderr+      when runInTerminal $+        writeChan syncErr $ T.encodeUtf8 (line <> "\n")++      -- Always output to Debug Console       withAdaptor $ Output.stderr line +stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdinForwardThread runInTerminal syncIn _withAdaptor = do+  when runInTerminal $ do+    -- We need to hijack stdin to write to it++    -- 1. Create a new pipe from writeEnd->readEnd+    (readEnd, writeEnd) <- createPipe++    -- 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+ -- | The main debugger thread launches a GHC.Debugger session. -- -- Then, forever:@@ -278,15 +290,3 @@           -- Cleanly exit when readDebuggerOutput is closed or thread is killed.           return () -compileTimeGhcWithoutPatchVersion :: Version-compileTimeGhcWithoutPatchVersion =-  let-    versionNumber = __GLASGOW_HASKELL__ :: Int-    (major, minor) = divMod versionNumber 100-  in-    makeVersion [major, minor]--forgetPatchVersion :: Version -> Version-forgetPatchVersion v = case versionBranch v of-  (major:minor:_patches) -> makeVersion [major, minor]-  _ -> v

@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings, DerivingStrategies #-}+-- | 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'+module Development.Debug.Adapter.Proxy+  ( serverSideHdbProxy+  , runInTerminalHdbProxy+  , ProxyLog(..)+  ) where++import DAP++import System.IO+import System.Exit (exitSuccess)+import System.Environment+import System.FilePath+import Control.Exception.Base+import Control.Monad+import Control.Monad.IO.Class+import Control.Concurrent+import qualified Data.List.NonEmpty as NE++import qualified Data.Text as T+import Network.Socket hiding (Debug)+import Network.Run.TCP+import qualified Network.Socket.ByteString as NBS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.HashMap.Strict as H++import GHC.Debugger.Logger+import Development.Debug.Adapter++newtype ProxyLog = ProxyLog T.Text+  deriving newtype Pretty++-- | Connect to a running @hdb proxy@ process on the given port+-- connectToHdbProxy :: Recorder (WithVerbosity x) -> Int -> DebugAdaptor ()+-- connectToHdbProxy = _++-- | Fork a new thread to run the server-side of the proxy.+--+-- 1. To setup:+-- Ask the DAP client to launch a process running @hdb proxy --port <port>@+-- by sending a 'runInTerminal' DAP reverse request. This is done outside of+-- this function by signaling the given MVar (this is the case because we cannot use `network` with `DebugAdaptor`+--+-- 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 :: Recorder (WithSeverity ProxyLog)+                   -> 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++  port <- liftIO $ socketPort sock++  _ <- liftIO $ forkIO $ ignoreIOException $ do+    runTCPServerWithSocket sock $ \scket -> do++      logWith l Info $ ProxyLog $ T.pack $ "Connected to client on port " ++ show port ++ "...!"+      putMVar client_conn_signal () -- signal ready (see #95)++      -- -- Read stdout from chan and write to socket+      _ <- forkIO $ ignoreIOException $ do+        forever $ do+          bs <- readChan dbOut+          logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket: " ++ BS8.unpack bs+          NBS.sendAll scket bs++      -- Read stderr from chan and write to socket+      _ <- forkIO $ ignoreIOException $ do+        forever $ do+          bs <- readChan dbErr+          logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs+          NBS.sendAll scket bs++      -- Read stdin from socket and write to chan+      let loop = do+            bs <- NBS.recv scket 4096+            if BS8.null bs+              then do+                logWith l Debug $ ProxyLog $ T.pack "Connection to client was closed."+                close scket+              else do+                logWith l Debug $ ProxyLog $ T.pack $ "Read from socket: " ++ BS8.unpack bs+                writeChan dbIn bs >> loop+       in ignoreIOException loop++  sendRunProxyInTerminal port++  where+    ignoreIOException a = catch a $ \(e::IOException) ->+      logWith l Info $ ProxyLog $ T.pack $ "Ignoring connection broken to proxy client: " ++ show e++-- | The proxy code running on the terminal in which the @hdb proxy@ process is launched.+--+-- This client-side proxy is responsible for+-- 1. Connecting to the given proxy-server port+-- 2. Forwarding stdin to the port it is connected to+-- 3. Read from the network the output and write it to stdout+runInTerminalHdbProxy :: Recorder (WithSeverity ProxyLog) -> Int -> IO ()+runInTerminalHdbProxy l port = do+  logWith l Info $ ProxyLog $ T.pack $ "Running in terminal on port " ++ show port ++ "...!"+  hSetBuffering stdin LineBuffering++  dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION"+  case dbg_inv of+    Nothing  -> pure ()+    Just inv ->+      putStrLn $ "Running the debugger input/output proxy for the following debuggee execution:\n\n\n    " ++ inv ++ "\n\n"++  catch (+    runTCPClient "127.0.0.1" (show port) $ \sock -> do+      -- Forward stdin to sock+      _ <- forkIO $+        catch (forever $ do+          str <- BS8.hGetLine stdin+          NBS.sendAll sock (str <> BS8.pack "\n")+          ) $ \(e::IOException) -> return () -- connection dropped, just exit.++      -- Forward stdout from sock+      catch (forever $ do+        msg <- NBS.recv sock 4096+        if BS8.null msg+          then do+            logWith l Info $ ProxyLog $ T.pack "Exiting..."+            close sock+            exitSuccess+          else BS8.hPut stdout msg >> hFlush stdout+        ) $ \(e::IOException) -> return () -- connection dropped, just exit.++    ) $ \(e::IOException) -> do+      hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?"++-- | Send a 'runInTerminal' reverse request to the DAP client+-- with the @hdb proxy@ invocation+sendRunProxyInTerminal :: PortNumber -> DebugAdaptor ()+sendRunProxyInTerminal port = do+  DAS { entryFile+      , entryPoint+      , entryArgs+      , projectRoot } <- getDebugSession+  let debuggee_inv = T.pack $ makeRelative projectRoot entryFile ++ ":" ++ entryPoint +++                              (if null entryArgs then "" else " ") ++ unwords entryArgs+  sendRunInTerminalReverseRequest+    RunInTerminalRequestArguments+      { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated+      , runInTerminalRequestArgumentsTitle = Just debuggee_inv+      , runInTerminalRequestArgumentsCwd = ""+      , runInTerminalRequestArgumentsArgs = ["hdb", "proxy", "--port", T.pack (show port)]+      , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv)+      , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False+      }

@@ -6,14 +6,15 @@ import System.Directory import System.Console.Haskeline import System.Console.Haskeline.Completion+import System.FilePath+import Control.Monad.Except 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 Development.Debug.Session.Setup  import GHC.Debugger.Logger import GHC.Debugger.Interface.Messages@@ -34,38 +35,39 @@     FlagsLog msg -> pretty msg  -- | Run it-runIDM :: String   -- ^ entryPoint+runIDM :: Recorder (WithSeverity InteractiveLog)+       -> String   -- ^ entryPoint        -> FilePath -- ^ entryFile        -> [String] -- ^ entryArgs        -> [String] -- ^ extraGhcArgs        -> InteractiveDM a        -> IO a-runIDM entryPoint entryFile entryArgs extraGhcArgs act = do+runIDM logger 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 hieBiosLogger = cmapWithSev FlagsLog logger+  runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case+    Left e               -> exitWithMsg e+    Right (Left e)       -> exitWithMsg e+    Right (Right flags)+      | HieBiosFlags{..} <- flags+                         -> do+       let defaultRunConf = RunDebuggerSettings-            { supportsANSIStyling = True+            { supportsANSIStyling = True -- todo: check!!             , supportsANSIHyperlinks = False             }+       let finalGhcInvocation = ghcInvocation ++ extraGhcArgs-      runDebugger stdout rootDir componentDir libdir units finalGhcInvocation entryFile defaultRunConf $+      let absEntryFile = normalise $ projectRoot </> entryFile++      runDebugger stdout rootDir componentDir libdir units finalGhcInvocation absEntryFile defaultRunConf $         fmap fst $           evalRWST (runInputT (setComplete noCompletion defaultSettings) act)                    (entryFile, entryPoint, entryArgs) Nothing   where-    exitWithMsg str = do-      putStrLn str+    exitWithMsg txt = do+      putStrLn txt       exitWith (ExitFailure 33)    --   completeF = completeWordWithPrev Nothing filenameWordBreakChars $@@ -223,6 +225,10 @@     ( info (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)+      ( progDesc "Terminate and exit the debugger session" ) )   )  -- | Main parser info

@@ -0,0 +1,42 @@+-- | Options supported by the debugger+--+-- For parsing see 'Development.Debug.Options.Parser'+module Development.Debug.Options+  ( HdbOptions(..) ) where++import GHC.Debugger.Logger++-- | The options `hdb` is invoked in the command line with+data HdbOptions+  -- | @server --port <port>@+  = HdbDAPServer+    { port :: Int+    , verbosity :: Verbosity+    }+  -- | @cli [--entry-point=<entryPoint>] [--extra-ghc-args="<args>"] [<entryFile>] -- [<entryArgs>]@+  | HdbCLI+    { entryPoint :: String+    , entryFile :: FilePath+    , entryArgs :: [String]+    , extraGhcArgs :: [String]+    , verbosity :: Verbosity+    }++  -- | @proxy --port <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.+  --+  -- 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.+  --+  -- See #44 for the original ticket+  | HdbProxy+    { port :: Int+    , verbosity :: Verbosity+    }+

@@ -0,0 +1,117 @@+-- | Options parser using optparse-applicative for the debugger options in+-- 'Development.Debug.Options'+module Development.Debug.Options.Parser+  ( -- * Command line options parsing+    parseHdbOptions+  ) where++import Options.Applicative hiding (command)++import Data.Version+import qualified Options.Applicative+import qualified Paths_haskell_debugger as P++import GHC.Debugger.Logger+import Development.Debug.Options++--------------------------------------------------------------------------------+-- Options parser+--------------------------------------------------------------------------------++-- | Parser for 'HdbDAPServer' options+serverParser :: Parser HdbOptions+serverParser = HdbDAPServer+  <$> option auto+      ( long "port"+     <> short 'p'+     <> metavar "PORT"+     <> help "DAP server port" )+  <*> verbosityParser (Verbosity Debug)++-- | 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" )+  <*> verbosityParser (Verbosity Warning)++-- | Parser for 'HdbProxy' options+proxyParser :: Parser HdbOptions+proxyParser = HdbProxy+  <$> option auto+      ( long "port"+     <> short 'p'+     <> metavar "PORT"+     <> help "proxy port to which the debugger connects" )+  <*> verbosityParser (Verbosity Warning)++-- | 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" ) )+ <> 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" ) )+  )+  <|> cliParser  -- Default to CLI mode if no subcommand++-- | Parser for --version flag+versioner :: Parser (a -> a)+versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version++-- | Parser for --verbosity 0+--+-- The default verbosity differs by mode (#86):+-- - DAP server mode: DEBUG+-- - CLI mode: WARNING+verbosityParser :: Verbosity -> Parser Verbosity+verbosityParser vdef = option verb+    ( long "verbosity"+   <> short 'v'+   <> metavar "VERBOSITY"+   <> value vdef+   <> help "Logger verbosity in [0..3] interval, where 0 is silent and 3 is debug"+    )+  where+    verb = Verbosity <$> (verbNum =<< auto)+    verbNum n = case n :: Int of+      0 -> pure Error+      1 -> pure Warning+      2 -> pure Info+      3 -> pure Debug+      _ -> readerAbort (ErrorMsg "Verbosity must be a value in [0..3]")++-- | Main parser info+hdbParserInfo :: ParserInfo HdbOptions+hdbParserInfo = info (hdbOptionsParser <**> versioner <**> 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

@@ -0,0 +1,344 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Development.Debug.Session.Setup+  (+  -- * Setting up a hie-bios session+    HieBiosFlags(..)+  , hieBiosSetup++  -- * Logging+  , FlagsLog(..)+  ) where++import Control.Applicative ((<|>))+import Control.Exception (handleJust)+import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Bifunctor+import Data.Function+import Data.Functor ((<&>))+import Data.Maybe+import Data.Version+import Data.Void+import System.Directory hiding (findFile)+import System.FilePath+import System.IO.Error+import Text.ParserCombinators.ReadP (readP_to_S)+import Prettyprinter++import qualified Data.Text as T++import qualified HIE.Bios as HIE+import qualified HIE.Bios.Config as Config+import qualified HIE.Bios.Cradle as HIE+import qualified HIE.Bios.Environment as HIE+import qualified HIE.Bios.Types as HIE+import qualified Hie.Cabal.Parser as Implicit+import qualified Hie.Locate as Implicit+import qualified Hie.Yaml as Implicit++import GHC.Debugger.Logger++data FlagsLog+  = HieBiosLog HIE.Log+  | LogCradle (HIE.Cradle Void)+  | LogSetupMsg T.Text++instance Pretty FlagsLog where+  pretty = \ case+    HieBiosLog msg -> pretty msg+    LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl+    LogSetupMsg txt -> pretty txt++-- | Flags inferred by @hie-bios@ to invoke GHC+data HieBiosFlags = HieBiosFlags+      { ghcInvocation :: [String]+      , libdir :: FilePath+      , units :: [String]+      , rootDir :: FilePath+      -- ^ Root dir as reported by the 'Cradle'+      , componentDir :: FilePath+      -- ^ Root dir of the loaded 'ComponentOptions'.+      -- Important for multi-package cabal projects, as packages are not in the+      -- root of the cradle, but in some sub-directory.+      }++-- | Prepare a GHC session using hie-bios from scratch+hieBiosSetup :: Recorder (WithSeverity FlagsLog)+             -> FilePath -- ^ project root+             -> FilePath -- ^ entry file+             -> ExceptT String IO (Either String HieBiosFlags)+hieBiosSetup logger projectRoot entryFile = do++  cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT++  -- GHC is found in PATH (by hie-bios as well).+  logT "Checking GHC version against debugger version..."+  _version <- hieBiosRuntimeGhcVersion logger cradle++  logT "Discovering session flags with hie-bios..."+  r <- hieBiosFlags logger cradle projectRoot entryFile     & liftIO++  logT "Session setup with hie-bios was successful."+  return r++  where+    logT = logWith logger Info . LogSetupMsg . T.pack++-- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@+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 hieBiosLogger target)+                  (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO+  logWith logger Info $ LogCradle cradle+  pure cradle+  where+    hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger++-- | Fetch the runtime GHC version, according to hie-bios, and check it is the+-- same as the compile time GHC version+hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog)+                         -> HIE.Cradle Void+                         -> ExceptT String IO Version+hieBiosRuntimeGhcVersion _logger cradle = do+  out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"++  case versionMaybe out of+    Nothing -> throwError $ "Failed to parse GHC version: " <> out+    Just actualVersion -> do++      -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1):+      when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do+        throwError $+          "Aborting...! The GHC version must be the same which " +++            "ghc-debug-adapter was compiled against (" +++              showVersion compileTimeGhcWithoutPatchVersion+++                "). Instead, got " ++ (showVersion actualVersion) ++ "."++      pure actualVersion++-- | Make 'HieBiosFlags' from the given target file+hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -}+             -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}+             -> FilePath {-^ Project root -}+             -> FilePath {-^ Entry file relative to root -}+             -> IO (Either String HieBiosFlags)+hieBiosFlags _logger cradle root relTarget = runExceptT $ do+  let target = root </> relTarget+  libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"++  -- To determine the flags we MUST set the current directory to the root+  -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does)+  -- (HIE.getCompilerOptions depends on CWD being the proper root dir)+  let compilerOpts = liftIO $ withCurrentDirectory root $+#if MIN_VERSION_hie_bios(0,14,0)+                          HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle+#else+                          HIE.getCompilerOptions target [] cradle+#endif+  componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"+#if __GLASGOW_HASKELL__ >= 913+  -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading+  -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch.+  -- ["-fwrite-if-simplified-core"] +++#endif++  let (units', flags') = extractUnits (HIE.componentOptions componentOpts)+  return HieBiosFlags+    { ghcInvocation = flags' ++ ghcDebuggerFlags+    , libdir = libdir+    , units  = units'+    , rootDir = HIE.cradleRootDir cradle+    , componentDir = HIE.componentRoot componentOpts+    }++unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a+unwrapCradleResult m = \case+  HIE.CradleNone      -> throwError $ "HIE.CradleNone\n" ++ m+  HIE.CradleFail err  -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m+  HIE.CradleSuccess x -> return x++extractUnits :: [String] -> ([String], [String])+extractUnits = go [] []+  where+    -- TODO: we should likely use the 'processCmdLineP' instead+    go units rest ("-unit" : x : xs) = go (x : units) rest xs+    go units rest (x : xs)           = go units (x : rest) xs+    go units rest []                 = (reverse units, reverse rest)++-- | Flags specific to haskell-debugger to append to all GHC invocations.+ghcDebuggerFlags :: [String]+ghcDebuggerFlags =+  [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt+  ]+++-- ----------------------------------------------------------------------------+-- Utilities+-- ----------------------------------------------------------------------------++versionMaybe :: String -> Maybe Version+versionMaybe xs = case reverse $ readP_to_S parseVersion xs of+  [] -> Nothing+  (x:_) -> Just (fst x)++-- ----------------------------------------------------------------------------+-- Implicit cradle discovery logic mirroring the one used by HLS.+-- The code itself is copy-pasted from HLS.+-- Obviously, we want to reuse the logic without having to depend on HLS.+-- We should factor out a common sub-component from HLS and use it here as well.+-- ----------------------------------------------------------------------------++loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a)+loadImplicitCradle l wfile = do+  is_dir <- doesDirectoryExist wfile+  let wdir | is_dir = wfile+           | otherwise = takeDirectory wfile+  cfg <- runMaybeT (implicitConfig wdir)+  case cfg of+    Just bc -> HIE.getCradle l absurd bc+    Nothing -> return $ HIE.defaultCradle l wdir++-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies+implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath)+implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree+  where+  noDeps :: [FilePath]+  noDeps = []+++inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+inferCradleTree start_dir =+       maybeItsBios+   -- If we have both a config file (cabal.project/stack.yaml) and a work dir+   -- (dist-newstyle/.stack-work), prefer that+   <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir))+   <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir)+   -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal+   <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle)+   -- If we have a stack.yaml, use stack+   <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle)+   -- If we have a cabal file, use cabal+   <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle)++  where+  maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir </> ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir++  cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir)++-- | Generate a stack cradle given a filepath.+--+-- Since we assume there was proof that this file belongs to a stack cradle+-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files.+-- We do not look for package.yaml, as we assume the corresponding .cabal has+-- been generated already.+--+-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then+-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to+-- component names.+stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath)+stackCradle fp = do+  pkgs <- Implicit.stackYamlPkgs fp+  pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs+  let yaml = fp </> "stack.yaml"+  pure $ (,fp) $ case pkgsWithComps of+    [] -> Config.Stack (Config.StackType Nothing (Just yaml))+    ps -> Config.StackMulti mempty $ do+      Implicit.Package n cs <- ps+      c <- cs+      let (prefix, comp) = Implicit.stackComponent n c+      pure (prefix, Config.StackType (Just comp) (Just yaml))++-- | By default, we generate a simple cabal cradle which is equivalent to the+-- following hie.yaml:+--+-- @+--   cradle:+--     cabal:+-- @+--+-- Note, this only works reliable for reasonably modern cabal versions >= 3.2.+simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath)+simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp)++cabalExecutable :: MaybeT IO FilePath+cabalExecutable = MaybeT $ findExecutable "cabal"++stackExecutable :: MaybeT IO FilePath+stackExecutable = MaybeT $ findExecutable "stack"++biosWorkDir :: FilePath -> MaybeT IO FilePath+biosWorkDir = findFileUpwards (".hie-bios" ==)++cabalWorkDir :: FilePath -> MaybeT IO ()+cabalWorkDir wdir = do+  check <- liftIO $ doesDirectoryExist (wdir </> "dist-newstyle")+  unless check $ fail "No dist-newstyle"++stackWorkDir :: FilePath -> MaybeT IO ()+stackWorkDir wdir = do+  check <- liftIO $ doesDirectoryExist (wdir </> ".stack-work")+  unless check $ fail "No .stack-work"++cabalConfigDir :: FilePath -> MaybeT IO FilePath+cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local")++cabalFileDir :: FilePath -> MaybeT IO FilePath+cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal")++stackConfigDir :: FilePath -> MaybeT IO FilePath+stackConfigDir = findFileUpwards isStack+  where+    isStack name = name == "stack.yaml"++-- | Searches upwards for the first directory containing a file to match+-- the predicate.+findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath+findFileUpwards p dir = do+  cnts <-+    liftIO+    $ handleJust+        -- Catch permission errors+        (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing)+        pure+        (findFile p dir)++  case cnts of+    [] | dir' == dir -> fail "No cabal files"+            | otherwise   -> findFileUpwards p dir'+    _ : _ -> return dir+  where dir' = takeDirectory dir++-- | Sees if any file in the directory matches the predicate+findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findFile p dir = do+  b <- doesDirectoryExist dir+  if b then getFiles >>= filterM doesPredFileExist else return []+  where+    getFiles = filter p <$> getDirectoryContents dir+    doesPredFileExist file = doesFileExist $ dir </> file++--------------------------------------------------------------------------------++compileTimeGhcWithoutPatchVersion :: Version+compileTimeGhcWithoutPatchVersion =+  let+    versionNumber = __GLASGOW_HASKELL__ :: Int+    (major, minor) = divMod versionNumber 100+  in+    makeVersion [major, minor]++forgetPatchVersion :: Version -> Version+forgetPatchVersion v = case versionBranch v of+  (major:minor:_patches) -> makeVersion [major, minor]+  _ -> v

@@ -2,11 +2,15 @@ module Main where  import System.Environment+import System.Process import Data.Maybe-import Data.Version+import Data.Aeson+import Data.IORef import Text.Read-import Control.Monad.Except+import Control.Concurrent+import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Except  import DAP @@ -18,98 +22,19 @@ import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles import GHC.Debugger.Logger-import Development.Debug.Adapter--import Development.Debug.Interactive+import Prettyprinter  import System.IO (hSetBuffering, BufferMode(LineBuffering)) 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 -import qualified Paths_haskell_debugger as P---- | 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---- | Parser for --version flag-versioner :: Parser (a -> a)-versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version---- | Main parser info-hdbParserInfo :: ParserInfo HdbOptions-hdbParserInfo = info (hdbOptionsParser <**> versioner <**> 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+import Development.Debug.Options (HdbOptions(..))+import Development.Debug.Options.Parser (parseHdbOptions)+import Development.Debug.Adapter+import Development.Debug.Adapter.Proxy+import Development.Debug.Interactive  -------------------------------------------------------------------------------- @@ -120,28 +45,33 @@ main :: IO () main = do   hdbOpts <- parseHdbOptions+  let+    timeStampLogger  = cmapIO renderWithTimestamp . fromCologAction+    loggerWithSev    = cmap renderPrettyWithSeverity+    loggerFinal opts = applyVerbosity opts.verbosity . loggerWithSev . timeStampLogger   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)+        let dapLogger = cmap DAP.renderDAPLog $ timeStampLogger l+        let runLogger = loggerFinal hdbOpts l+        init_var <- liftIO (newIORef False{-not supported by default-})+        pid_var  <- liftIO (newIORef Nothing)+        ccon_var <- liftIO newEmptyMVar+        runDAPServerWithLogger (toCologAction dapLogger) config+          (talk runLogger init_var pid_var ccon_var)+          (ack runLogger pid_var)     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)-+        l <- handleLogger stdout+        let runLogger = cmapWithSev InteractiveLog $ loggerFinal hdbOpts l+        runIDM runLogger entryPoint entryFile entryArgs extraGhcArgs $+          debugInteractive runLogger+    HdbProxy{port} -> do+        l <- handleLogger stdout+        let runLogger = cmapWithSev RunProxyClientLog $ loggerFinal hdbOpts l+        runInTerminalHdbProxy runLogger port  -- | Fetch config from environment, fallback to sane defaults getConfig :: Int -> IO ServerConfig@@ -194,29 +124,64 @@  data MainLog   = InitLog InitLog+  | LaunchLog T.Text   | InteractiveLog InteractiveLog+  | RunProxyServerLog ProxyLog+  | RunProxyClientLog ProxyLog  instance Pretty MainLog where   pretty = \ case     InitLog msg -> pretty msg+    LaunchLog msg -> pretty msg+    InteractiveLog msg -> pretty msg+    RunProxyServerLog msg -> pretty ("Proxy Server:" :: String) <+> pretty msg+    RunProxyClientLog msg -> pretty ("Proxy Client:" :: String) <+> 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 :: Recorder (WithSeverity MainLog) -> Command -> DebugAdaptor ()+talk :: Recorder (WithSeverity 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.+     -> Command -> DebugAdaptor () ---------------------------------------------------------------------------------talk l = \ case+talk l support_rit_var pid_var client_proxy_signal = \ case   CommandInitialize -> do-    -- InitializeRequestArguments{..} <- getArguments+    InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments+    let runInTerminal = fromMaybe False supportsRunInTerminalRequest+    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-    merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) launch_args++    supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var++    merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) supportsRunInTerminalRequest 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 (cmapWithSev RunProxyServerLog l) client_proxy_signal++        logWith l Info $ LaunchLog $ T.pack "Debugger launched successfully."+       Left (InitFailed err) -> do         sendErrorResponse (ErrorMessage (T.pack err)) Nothing         exitCleanly@@ -237,6 +202,9 @@   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     startExecution >>= handleEvalResult False ----------------------------------------------------------------------------   CommandThreads    -> commandThreads@@ -253,13 +221,33 @@ ----------------------------------------------------------------------------   CommandEvaluate   -> commandEvaluate -----------------------------------------------------------------------------  CommandTerminate  -> commandTerminate+  CommandTerminate  -> do+    commandTerminate   CommandDisconnect -> commandDisconnect ----------------------------------------------------------------------------   CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)   CommandSource -> undefined-  CommandPause -> 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 ---------------------------------------------------------------------------- -- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ----------------------------------------------------------------------------++-- | Receive reverse request responses (such as runInTerminal response)+ack :: Recorder (WithSeverity MainLog)+    -> IORef (Maybe Int)+    -- ^ Reference to PID of runInTerminal proxy process running+    -> ReverseRequestResponse -> DebugAdaptorCont ()+ack l ref rrr = case rrr.reverseRequestCommand of+  ReverseCommandRunInTerminal -> do+    when rrr.success $ do+      logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful"+  _ -> pure ()+

@@ -1,4 +1,121 @@+{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes #-} module Main (main) where +import Text.RE.TDFA.Text.Lazy+import Text.Printf+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import qualified Data.Text.Lazy.IO as LT+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified System.Process as P+import System.FilePath+import System.IO.Temp+import System.Exit+import System.IO+import Control.Exception++import Test.Tasty+import Test.Tasty.Golden as G+import Test.Tasty.Golden.Advanced as G++import Test.DAP.RunInTerminal+import Test.Utils+ main :: IO ()-main = putStrLn "Test suite not yet implemented."+main = do+  goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden"+  defaultMain $+    testGroup "Tests"+      [ testGroup "Golden tests" goldens+      , testGroup "Unit tests" unitTests+      ]++unitTests =+  [ runInTerminalTests+  ]++-- | Receives as an argument the path to the @*.hdb-test@ which contains the+-- shell invocation for running +mkGoldenTest :: Bool -> FilePath -> IO TestTree+mkGoldenTest keepTmpDirs path = do+  let testName   = takeBaseName     path+  let goldenPath = replaceExtension path ".hdb-stdout"+  return (goldenVsStringComparing testName goldenPath action)+  where+    action :: IO LBS.ByteString+    action = do+      script <- readFile path+      withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do+        (_, Just hout, _, p)+          <- P.createProcess (P.shell script){P.cwd = Just test_dir, P.std_out = P.CreatePipe}+        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+--------------------------------------------------------------------------------++-- | Compare a given string against the golden file's contents using the given normalising function+-- This is inlined from 'goldenVsString' and the accompanying functions. We+-- wanted the same but with a normalising function.+goldenVsStringComparing+  :: TestName -- ^ test name+  -> FilePath -- ^ path to the «golden» file (the file that contains correct output)+  -> IO LBS.ByteString+  -- ^ 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++  -- 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++  -- Normalise the action producing the output+  normalisingAct = do+    tmpDir <- getCanonicalTemporaryDirectory+    replaceRE <- compileSearchReplace (tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-})+                                      "<TEMPORARY-DIRECTORY>"++    let normalising (LT.decodeUtf8 -> txt) = txt *=~/ replaceRE++    normalising <$> act++  readFileStrict :: FilePath -> IO LBS.ByteString+  readFileStrict path = do+    s <- LBS.readFile path+    evaluate $ forceLbs s+    return s++  forceLbs :: LBS.ByteString -> ()+  forceLbs = LBS.foldr seq ()++--------------------------------------------------------------------------------+-- Normalisation+--------------------------------------------------------------------------------++  -- | Compare the golden test against the actual output after normalisation+  cmpNormalising :: LT.Text -> LT.Text -> IO (Maybe String)+  cmpNormalising x y = do++    let+      msg = printf "Test output was different from '%s'. It was:\n" ref <> (LT.unpack y)++    if x == y+      then return Nothing+      else do+        -- Call diff to show the difference+        withSystemTempFile "x.txt" $ \xf xH -> do+          withSystemTempFile "y.txt" $ \yf yH -> do+            LT.hPutStr xH x+            LT.hPutStr yH y+            hFlush xH+            hFlush yH+            hClose xH+            hClose yH+            (_exitCode, out, err) <- P.readProcessWithExitCode "diff" ["-u", xf, yf] ""+            return $ Just $ msg ++ "\nDiff output:\n" ++ out ++ err+

@@ -0,0 +1,122 @@+-- | Utils essentially copied from `dap`'s test suite+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+module Test.DAP where++----------------------------------------------------------------------------+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 )+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++-- | 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+    ]++-- | 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++--------------------------------------------------------------------------------++-- | Sample host shared amongst client and server+--+testHost :: String+testHost = "127.0.0.1"++-- | 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)++-- | Helper to send JSON payloads to the server+--+send :: Handle -> [Pair] -> IO ()+send h message+  = BS.hPutStr h $ encodeBaseProtocolMessage (object message)++-- | Helper to receive JSON payloads to the client+-- checks if 'Handle' returns a subset expected payload+--+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 actual @=? encodePretty ex+    _ -> fail "Invalid JSON"

@@ -0,0 +1,279 @@+-- | 'runInTerminal' tests+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE LambdaCase #-}+module Test.DAP.RunInTerminal (runInTerminalTests) where++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.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"+    [ testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1+    ]++rit_keep_tmp_dirs :: Bool+rit_keep_tmp_dirs = False++runInTerminal1 = 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 --port " ++ show testPort)+          {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe}++    -- 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 $ do+      hSetBuffering hout LineBuffering+      let loop = do+            eof <- hIsEOF hout+            if eof+              then return ()+              else do+                _l <- hGetLine hout+                -- putStrLn ("[server] " ++ l)+                loop+      loop++    retryVar <- newIORef True+    -- Connect to the DAP server+    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)+            ]+        ]++      _ <- shouldReceive handle+            ["type" .= ("event" :: String), "event" .= ("output" :: String)]+      _ <- 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: " ++ out_str)+                 ("hello" `isInfixOf` out_str)+      assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ 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+

@@ -0,0 +1,25 @@+module Test.Utils where++import System.FilePath+import System.IO.Temp+import qualified System.Process as P++-- | Copy the contents of a test directory (with a `*.hdb-test` in the root) to+-- a temporary location and return the path to the new location.+withHermeticDir :: Bool               -- ^ Whether to keep the temp dir around for inspection+                -> FilePath           -- ^ Test dir+                -> (FilePath -> IO r) -- ^ Continuation receives hermetic test dir (in temporary dir)+                -> IO r+withHermeticDir keep src k = do+  withTmpDir "hdb-test" $ \dest -> do+    P.callCommand $ "cp -r " ++ src ++ " " ++ dest+    k (dest </> takeBaseName src)+  where+    withTmpDir | keep      = withPersistentSystemTempDirectory+               | otherwise = withSystemTempDirectory++    withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r+    withPersistentSystemTempDirectory template k' = do+      dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory+      k' dir+