Improve launch defaults and failure message

Make all launch settings have a sensible default except for "entryFile"
which is always required.

When "entryFile" is not provided, the error should be correctly reported
via an ErrorResponse message.

Fixes #71

Author: alt-romes

hdb/Development/Debug/Adapter/Exit.hs

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

hdb/Development/Debug/Adapter/Init.hs

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

hdb/Main.hs

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

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

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

test/integration-tests/test/adapter.test.ts

@@ -125,53 +125,46 @@ describe("Debug Adapter Tests", function () {
 
     const basicTests = (launchCfg) => {
 
-        // The most basic functionality we test on various different
-        // configurations (such as Cabal vs without project vs Stack)
-        // The remaining tests are run only on one config since the set up
-        // starts being more specific (e.g. multiple home units with Cabal)
-        describe("Most basic functionality", function () {
-
-          describe(launchCfg.name, function () {
-
-              it('should run program to the end', () => {
-                  return Promise.all([
-                      dc.configurationSequence(),
-                      dc.launch(launchCfg.config),
-                      dc.waitForEvent('exited').then(e => new Promise((resolve, reject) => {
-                          if (e.body.exitCode == 0)
-                              resolve(e)
-                          else
-                              reject(new Error("Expecting ExitCode 1"))
-                      }))
-                  ]);
-              });
-
-              it('should stop on a breakpoint', () => {
-                  const expected = { path: launchCfg.config.projectRoot + "/" + launchCfg.config.entryFile, line: 6 }
-                  return dc.hitBreakpoint(launchCfg.config, { path: launchCfg.config.entryFile, line: 6 }, expected, expected);
-              });
-
-              it('should stop on an exception', () => {
-
-                  // const expected = { path: launchCfg.config.projectRoot + "/" + launchCfg.config.entryFile, line: 10 }
-                  // Currently, no information is provided when stopped at an exception:
-                  const expected = { }
-                  return Promise.all([
-
-                      dc.waitForEvent('initialized').then(event => {
-                          return dc.setExceptionBreakpointsRequest({
-                              filters: [ 'break-on-exception' ]
-                          });
-                      }).then(response => {
-                          return dc.configurationDoneRequest();
-                      }),
-
-                      dc.launch(launchCfg.config),
-
-                      dc.assertStoppedLocation('exception', expected)
-                  ]);
-              });
-          })
+        describe(launchCfg.name, function () {
+
+            it('should run program to the end', () => {
+                return Promise.all([
+                    dc.configurationSequence(),
+                    dc.launch(launchCfg.config),
+                    dc.waitForEvent('exited').then(e => new Promise((resolve, reject) => {
+                        if (e.body.exitCode == 0)
+                            resolve(e)
+                        else
+                            reject(new Error("Expecting ExitCode 1"))
+                    }))
+                ]);
+            });
+
+            it('should stop on a breakpoint', () => {
+                const expected = { path: launchCfg.config.projectRoot + "/" + launchCfg.config.entryFile, line: 6 }
+                return dc.hitBreakpoint(launchCfg.config, { path: launchCfg.config.entryFile, line: 6 }, expected, expected);
+            });
+
+            it('should stop on an exception', () => {
+
+                // const expected = { path: launchCfg.config.projectRoot + "/" + launchCfg.config.entryFile, line: 10 }
+                // Currently, no information is provided when stopped at an exception:
+                const expected = { }
+                return Promise.all([
+
+                    dc.waitForEvent('initialized').then(event => {
+                        return dc.setExceptionBreakpointsRequest({
+                            filters: [ 'break-on-exception' ]
+                        });
+                    }).then(response => {
+                        return dc.configurationDoneRequest();
+                    }),
+
+                    dc.launch(launchCfg.config),
+
+                    dc.assertStoppedLocation('exception', expected)
+                ]);
+            });
         })
     }
 
@@ -233,7 +226,41 @@ describe("Debug Adapter Tests", function () {
         assert.strictEqual(v.variablesReference, 0, `Variable ${v.name} should not be expandable (because it is a String)`);
     }
 
-    simpleLaunchConfigs.forEach(basicTests);
+    // The most basic functionality we test on various different
+    // configurations (such as Cabal vs without project vs Stack)
+    // The remaining tests are run only on one config since the set up
+    // starts being more specific (e.g. multiple home units with Cabal)
+    describe("Most basic functionality", function () {
+        simpleLaunchConfigs.forEach(basicTests);
+
+        describe("Other basic tests", function () {
+            it('report error on missing "entryFile"', () => {
+                let config = mkConfig({
+                      projectRoot: "/data/T71",
+                    })
+
+                const expected = { path: config.projectRoot + "/" + config.entryFile, line: 1 }
+                // 'Launch' the debugger using this config and expect the response to the launch request to be a ResponseError with message "Missing \"entryFile\""
+                return dc.launch(config).then(
+                        () => Promise.reject(new Error("Expecting launch to fail")),
+                        (err) => {
+                            assert.strictEqual(err.message, 'Missing "entryFile" key in debugger configuration');
+                        }
+                    )
+            })
+
+            it('minimal configuration with just entryFile', async () => {
+                let config = mkConfig({
+                      projectRoot: "/data/T71",
+                      entryFile: "Main.hs",
+                    })
+
+                const expected = { path: config.projectRoot + "/" + config.entryFile, line: 2 }
+                return dc.hitBreakpoint(config, { path: config.entryFile, line: 2 }, expected, expected)
+            })
+        })
+
+    })
 
     describe("Multiple main function tests", function () {
         const multiMainConfig = mkConfig({