diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index bf7a724..fa3faed 100644 --- a/haskell-debugger.cabal +++ b/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: diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 68c3913..6830e7c 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/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 $ diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 3a888d6..3d5e7fe 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/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 diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 2a4c08e..8770cdf 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -7,14 +7,14 @@ 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 @@ instance Pretty InteractiveLog where 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 $ @@ -225,6 +225,10 @@ cmdParser entryFile entryPoint entryArgs = hsubparser ( 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 diff --git a/hdb/Development/Debug/Adapter/Flags.hs b/hdb/Development/Debug/Session/Setup.hs similarity index 82% rename from hdb/Development/Debug/Adapter/Flags.hs rename to hdb/Development/Debug/Session/Setup.hs index a52678f..9306dd9 100644 --- a/hdb/Development/Debug/Adapter/Flags.hs +++ b/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 diff --git a/hdb/Main.hs b/hdb/Main.hs index 7f22296..33e38fa 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -146,29 +146,25 @@ defaultStdoutForwardingAction line = do 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 diff --git a/test/golden/T61/T61.hdb-stdout b/test/golden/T61/T61.hdb-stdout index c0ea587..1edc519 100644 --- a/test/golden/T61/T61.hdb-stdout +++ b/test/golden/T61/T61.hdb-stdout @@ -1,6 +1,3 @@ -[INFO] Determined Cradle: Cradle{ cradleRootDir = "/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 ( /x/Main.hs, interpreted )[main] (hdb) wrks EvalCompleted {resultVal = "()", resultType = "()"} diff --git a/test/golden/T79/T79.hdb-stdout b/test/golden/T79/T79.hdb-stdout new file mode 100644 index 0000000..3f16f44 --- /dev/null +++ b/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 ( -tmp] +(hdb) Hello, Haskell! +EvalCompleted {resultVal = "()", resultType = "()"} +(hdb) \ No newline at end of file diff --git a/test/golden/T79/T79.hdb-test b/test/golden/T79/T79.hdb-test new file mode 100644 index 0000000..09f28a7 --- /dev/null +++ b/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) diff --git a/test/golden/T83/T83.hdb-stdout b/test/golden/T83/T83.hdb-stdout index d0e1944..7181372 100644 --- a/test/golden/T83/T83.hdb-stdout +++ b/test/golden/T83/T83.hdb-stdout @@ -1,6 +1,3 @@ -[INFO] Determined Cradle: Cradle{ cradleRootDir = "", 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 ( /Main.hs, interpreted )[main] (hdb) Heli EvalCompleted {resultVal = "()", resultType = "()"} diff --git a/test/integration-tests/test/adapter.test.ts b/test/integration-tests/test/adapter.test.ts index 8877d61..b16a67a 100644 --- a/test/integration-tests/test/adapter.test.ts +++ b/test/integration-tests/test/adapter.test.ts @@ -285,7 +285,7 @@ describe("Debug Adapter Tests", function () { ]); }); it("should stop at break-point", () => { - const expected = { path: multiMainConfig.projectRoot + "/./" + multiMainConfig.entryFile, line: 6 }; + const expected = { path: multiMainConfig.projectRoot + "/" + multiMainConfig.entryFile, line: 6 }; return dc.hitBreakpoint(multiMainConfig, { path: multiMainConfig.entryFile, line: 6 }, expected, expected); }); @@ -347,7 +347,7 @@ describe("Debug Adapter Tests", function () { }); it("should stop at break-point in the same home unit", () => { - const expected = { path: mhuConfig.projectRoot + "/./" + mhuConfig.entryFile, line: 8 }; + const expected = { path: mhuConfig.projectRoot + "/" + mhuConfig.entryFile, line: 8 }; return dc.hitBreakpoint(mhuConfig, { path: mhuConfig.entryFile, line: 8 }, expected, expected); });