Canonicalize special target and root

haskell-debugger.cabal

@@ -93,8 +93,7 @@ library
 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,
@@ -105,6 +104,7 @@ executable hdb
                       Development.Debug.Adapter.Handles,
                       Development.Debug.Adapter,
                       Development.Debug.Interactive,
+                      Development.Debug.Session.Setup,
                       Paths_haskell_debugger
     autogen-modules:  Paths_haskell_debugger
     build-depends:

haskell-debugger/GHC/Debugger/Session.hs

@@ -86,7 +86,9 @@ parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do
         -- 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 =
@@ -95,10 +97,11 @@ parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do
           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 $

hdb/Development/Debug/Adapter/Init.hs

@@ -17,7 +17,6 @@ import Control.Monad.Trans
 import Data.Function
 import Data.Functor
 import Data.Maybe
-import Data.Version (Version(..), showVersion, makeVersion)
 import System.IO
 import GHC.IO.Encoding
 import Control.Monad.Catch
@@ -31,7 +30,6 @@ import System.FilePath
 
 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
 
@@ -42,6 +40,7 @@ import GHC.Debugger.Interface.Messages hiding (Command, Response)
 
 import DAP
 import Development.Debug.Adapter.Handles
+import Development.Debug.Session.Setup
 
 --------------------------------------------------------------------------------
 -- * Logging
@@ -83,7 +82,7 @@ data LaunchArgs
 -- * Launch Debugger
 --------------------------------------------------------------------------------
 
--- | Exception type for when initialization fails
+-- | Exception type for when hie-bios initialization fails
 newtype InitFailed = InitFailed String deriving Show
 
 -- | Initialize debugger
@@ -107,31 +106,10 @@ initDebugger l LaunchArgs{ __sessionId
   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 -> lift $ exitWithMsg 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
@@ -277,15 +255,3 @@ handleDebuggerOutput readDebuggerOutput withAdaptor = do
           -- 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

hdb/Development/Debug/Interactive.hs

@@ -5,16 +5,16 @@
 import System.Exit
 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
@@ -35,39 +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)
-    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
       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 $
@@ -123,11 +123,11 @@
   GotStacktrace stackframes -> outputStrLn $ show stackframes
   GotScopes scopeinfos -> outputStrLn $ show scopeinfos
   GotVariables vis -> outputStrLn $ show vis -- (Either VarInfo [VarInfo])
   Aborted str -> outputStrLn ("Aborted: " ++ str)
   Initialised -> pure ()
 
 printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM ()
 printEvalResult recd EvalStopped{breakId} = do
   out <- lift . lift $ execute recd GetScopes
   printResponse recd out
 printEvalResult _ er = outputStrLn $ show er
@@ -175,7 +175,7 @@
   -- just "run"
   <|> (pure $ DebugExecution (mkEntry entryPoint) entryFile entryArgs)
   where
     parseEntry =
       fmap mkEntry $
       option str
         ( long "entry"
@@ -225,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
@@ -249,4 +253,4 @@
        in outputStrLn msg >> pure Nothing
     _ -> outputStrLn "Unsupported command parsing mode" >> pure Nothing
 
 parserPrefs = prefs (disambiguate <> showHelpOnError <> showHelpOnEmpty)

hdb/Development/Debug/Adapter/Flags.hs → hdb/Development/Debug/Session/Setup.hs

@@ -3,7 +3,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module Development.Debug.Adapter.Flags where
+module Development.Debug.Session.Setup
+  (
+  -- * Setting up a hie-bios session
+    HieBiosFlags(..)
+  , hieBiosSetup
+
+  -- * Logging
+  , FlagsLog(..)
+  ) where
 
 import Control.Applicative ((<|>))
 import Control.Exception (handleJust)
@@ -23,6 +31,8 @@ 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
@@ -37,11 +47,13 @@ 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
@@ -56,6 +68,29 @@ data HieBiosFlags = HieBiosFlags
       -- 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 -}
@@ -70,14 +105,27 @@ hieBiosCradle logger root relTarget = runExceptT $ do
   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
-                         -> IO (Either String Version)
-hieBiosRuntimeGhcVersion _logger cradle = runExceptT $ do
+                         -> 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 ver -> pure ver
+    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 -}
@@ -279,3 +327,18 @@ findFile p dir = do
   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

hdb/Main.hs

@@ -146,29 +146,25 @@
 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
-          loggerFinal = applyVerbosity hdbOpts.verbosity loggerWithSev
-        runDAPServerWithLogger (toCologAction $ cmap DAP.renderDAPLog timeStampLogger) config (talk loggerFinal)
+        let dapLogger = cmap DAP.renderDAPLog $ timeStampLogger l
+        let runLogger = loggerFinal hdbOpts l
+        runDAPServerWithLogger (toCologAction dapLogger) config $
+          talk runLogger
     HdbCLI{..} -> do
-      l <- handleLogger stdout
-      let
-        timeStampLogger :: Recorder T.Text
-        timeStampLogger = cmapIO renderWithTimestamp (fromCologAction l)
-        loggerWithSev :: Recorder (WithSeverity MainLog)
-        loggerWithSev = cmap renderPrettyWithSeverity timeStampLogger
-        loggerFinal = applyVerbosity hdbOpts.verbosity loggerWithSev
-      runIDM entryPoint entryFile entryArgs extraGhcArgs $
-        debugInteractive (cmapWithSev InteractiveLog loggerFinal)
+        l <- handleLogger stdout
+        let runLogger = cmapWithSev InteractiveLog $ loggerFinal hdbOpts l
+        runIDM runLogger entryPoint entryFile entryArgs extraGhcArgs $
+          debugInteractive runLogger
 
 
 -- | Fetch config from environment, fallback to sane defaults
@@ -234,7 +230,7 @@
 -- is implemented in this function.
 talk :: Recorder (WithSeverity MainLog) -> Command -> DebugAdaptor ()
 --------------------------------------------------------------------------------
 talk l = \ case
   CommandInitialize -> do
     -- InitializeRequestArguments{..} <- getArguments
     sendInitializeResponse

test/golden/T61/T61.hdb-stdout

@@ -1,6 +1,3 @@
-[INFO] Determined Cradle: Cradle{ cradleRootDir = "<TEMPORARY-DIRECTORY>/x", cradleOptsProg = CradleAction: Default}
-[DEBUG] ghc --print-libdir
-[INFO] invoking build tool to determine build flags (this may take some time depending on the cache)
 [1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>/x/Main.hs, interpreted )[main]
 (hdb) wrks
 EvalCompleted {resultVal = "()", resultType = "()"}

test/golden/T79/T79.hdb-stdout

@@ -0,0 +1,13 @@
+[Info] Using cabal specification: 3.14
+[Warn] unknown license type, you must put a copy in LICENSE yourself.
+[Info] Creating fresh file CHANGELOG.md...
+[Info] Creating fresh directory ./app...
+[Info] Creating fresh file app/Main.hs...
+[Info] Creating fresh file T79-tmp.cabal...
+[Warn] No synopsis given. You should edit the .cabal file and add one.
+[Info] You may want to edit the .cabal file and add a Description field.
+
+[1 of 2] Compiling Main             ( <TEMPORARY-DIRECTORY>-tmp]
+(hdb) Hello, Haskell!
+EvalCompleted {resultVal = "()", resultType = "()"}
+(hdb) 

test/golden/T79/T79.hdb-test

@@ -0,0 +1 @@
+cd $(mktemp -d) && cabal init -m -n -d base -p T79-tmp && (echo "run\nexit" | hdb app/Main.hs)