diff --git a/.vscode/launch.json b/.vscode/launch.json index fcd0106d..ee5b41fd 100644 --- a/.vscode/launch.json +++ b/.vscode/launch.json @@ -9,7 +9,8 @@ "entryFile": "hdb/Main.hs", "entryArgs": ["server", "--port", "12345"], "entryPoint": "main", - "extraGhcArgs": [] + "extraGhcArgs": [], + "cradleFile" : "hie-self-debug.yaml" }, { "type": "haskell-debugger", @@ -19,7 +20,8 @@ "entryFile": "test/haskell/Main.hs", "entryPoint": "main", "entryArgs": ["--pattern", "DAP.Scopes"], - "extraGhcArgs": [] + "extraGhcArgs": [], + "cradleFile": "hie-self-debug.yaml" } ] } diff --git a/cabal.project.self-debug-test b/cabal.project.self-debug-test new file mode 100644 index 00000000..067a063f --- /dev/null +++ b/cabal.project.self-debug-test @@ -0,0 +1,7 @@ +-- cabal project file used for self-debug tests. +-- Meant to be just `cabal.project` but separate file to prevent cabal +-- from including `cabal.project.local` as well. +-- +-- Referenced by hie-self-debug-test.yaml + +import: cabal.project diff --git a/hdb-dap/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs index b77694a9..fca21fbe 100644 --- a/hdb-dap/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -80,6 +80,8 @@ data LaunchArgs -- or function arguments otherwise. , extraGhcArgs :: Maybe [String] -- ^ Additional arguments to pass to the GHC invocation inferred by hie-bios for this project + , cradleFile :: Maybe FilePath + -- ^ specify cradle file rather than let it be inferred from @entryFile@, relative to @projectRoot@. } deriving stock (Show, Eq, Generic) deriving anyclass FromJSON @@ -115,6 +117,7 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter , entryPoint = fromMaybe "main" -> entryPoint , entryArgs = fromMaybe [] -> entryArgs , extraGhcArgs = fromMaybe [] -> extraGhcArgs + , cradleFile } = do syncRequests <- liftIO newEmptyMVar syncResponses <- liftIO newEmptyMVar @@ -144,7 +147,7 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter WithSeverity msg sev | sev >= Info -> dapLogger <& renderSessionSetupLog msg | otherwise -> mempty - let debugRunnerConf = DebugRunnerConf projectRoot entryFile extraGhcArgs + let debugRunnerConf = DebugRunnerConf projectRoot entryFile extraGhcArgs cradleFile liftIO (getDebugRunner servConf hieBiosLogger debugRunnerConf) >>= \case Left e -> throwError (ErrorMessage (T.pack e), Nothing) Right (ghcInvocation, debugRunner) -> do diff --git a/hdb-dap/Development/Debug/Session/Setup.hs b/hdb-dap/Development/Debug/Session/Setup.hs index 3f4b0f50..93ea2346 100644 --- a/hdb-dap/Development/Debug/Session/Setup.hs +++ b/hdb-dap/Development/Debug/Session/Setup.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Development.Debug.Session.Setup ( @@ -75,6 +76,10 @@ data DebugRunnerConf = DebugRunnerConf { drcProjectRoot :: FilePath , drcEntryFile :: FilePath , drcExtraGhcArgs :: [String] + , drcCradleFile :: Maybe FilePath + -- ^ specified cradle file rather than letting be inferred from + -- @drcEntryFile@, relative to @drcProjectRoot@ if so. @DebugRunnerProvider@s + -- must WARN if this field is @Just@ but they do not use hie cradles. } data SessionSetupLog @@ -106,11 +111,12 @@ data HieBiosFlags = HieBiosFlags hieBiosSetup :: LogAction IO (WithSeverity SessionSetupLog) -> FilePath -- ^ project root -> FilePath -- ^ entry file + -> Maybe FilePath -- ^ cradle file -> ExceptT String IO (Either String HieBiosFlags) -hieBiosSetup logger projectRoot entryFile = do +hieBiosSetup logger projectRoot entryFile cradleFile = do logInfo "Figuring out the right flags to compile the project using hie-bios..." - cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT + cradle <- hieBiosCradle logger projectRoot entryFile cradleFile & ExceptT -- GHC is found in PATH (by hie-bios as well). logInfo "Checking GHC version against debugger version..." @@ -129,10 +135,16 @@ hieBiosSetup logger projectRoot entryFile = do hieBiosCradle :: LogAction IO (WithSeverity SessionSetupLog) -> FilePath -- ^ Project root -> FilePath -- ^ Entry file relative to root + -> Maybe FilePath -- ^ Cradle file relative to root -> IO (Either String (HIE.Cradle Void)) -hieBiosCradle logger root relTarget = runExceptT $ do +hieBiosCradle logger root relTarget mrelCradle = runExceptT $ do let target = root relTarget - explicitCradle <- HIE.findCradle target & liftIO + explicitCradle <- case mrelCradle of + Nothing -> HIE.findCradle target & liftIO + Just ((root ) -> cradleFile) -> do + liftIO (doesFileExist cradleFile) >>= \case + True -> return $ Just cradleFile + False -> throwError $ "Specified Cradle file does not exist: " ++ cradleFile cradle <- maybe (loadImplicitCradle hieBiosLogger target) (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO liftLogIO logger <& WithSeverity (LogCradle cradle) Info @@ -219,8 +231,8 @@ hieDebugRunner :: LogAction IO (WithSeverity SessionSetupLog) -> DebugRunnerConf -> IO (Either String (GhcInvocation, Debugger.DebugRunner Ghc a)) -hieDebugRunner l (DebugRunnerConf projectRoot entryFile extraGhcArgs) = runExceptT $ do - r <- hieBiosSetup l projectRoot entryFile +hieDebugRunner l (DebugRunnerConf projectRoot entryFile extraGhcArgs cradleFile) = runExceptT $ do + r <- hieBiosSetup l projectRoot entryFile cradleFile HieBiosFlags{..} <- case r of Left e -> throwError e Right f -> return f diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 01e79062..eed210fd 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -47,14 +47,15 @@ runIDM :: LogAction IO InteractiveLog -> FilePath -- ^ entryFile -> [String] -- ^ entryArgs -> [String] -- ^ extraGhcArgs + -> Maybe FilePath -> RunDebuggerSettings -> InteractiveDM a -> IO a -runIDM logger entryPoint entryFile entryArgs extraGhcArgs runConf act = do +runIDM logger entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf act = do projectRoot <- getCurrentDirectory let hieBiosLogger = contramap ISessionSetupLog logger - hieDebugRunner hieBiosLogger (DebugRunnerConf projectRoot entryFile extraGhcArgs) >>= \case + hieDebugRunner hieBiosLogger (DebugRunnerConf projectRoot entryFile extraGhcArgs cradleFile) >>= \case Left e -> exitWithMsg e Right (_ghcInvocation, debugRunner) -> do diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs index 39ebf324..07c78d96 100644 --- a/hdb/Development/Debug/Options.hs +++ b/hdb/Development/Debug/Options.hs @@ -21,6 +21,7 @@ data HdbOptions , entryFile :: FilePath , entryArgs :: [String] , extraGhcArgs :: [String] + , cradleFile :: Maybe FilePath , verbosity :: Severity , internalInterpreter :: Bool , disableIpeBacktraces :: Bool diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs index 2b4e0473..2cfa6162 100644 --- a/hdb/Development/Debug/Options/Parser.hs +++ b/hdb/Development/Debug/Options/Parser.hs @@ -54,6 +54,12 @@ cliParser = HdbCLI <> metavar "GHC_ARGS" <> value [] <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) + <*> option (Just <$> str) + (long "cradle-file" + <> metavar "HIE_PATH" + <> value Nothing + <> help "Path to .yaml file to use as cradle configuration. Location inferred from ENTRY_POINT otherwise." + ) <*> verbosityParser Warning <*> internalInterpreterParser <*> disableIpeBacktracesParser diff --git a/hdb/Main.hs b/hdb/Main.hs index 94c2553e..2e69ab23 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -96,7 +96,7 @@ main = do , externalInterpreterCustomProc = Left stdinStream , externalInterpreterProg = thisProg } - runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs + runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf debugInteractive HdbProxy{port} -> do setBacktraceMechanismState IPEBacktrace True diff --git a/hie-self-debug-test.yaml b/hie-self-debug-test.yaml new file mode 100644 index 00000000..5c68ca1d --- /dev/null +++ b/hie-self-debug-test.yaml @@ -0,0 +1,6 @@ +# HIE cradle used for self-debug tests. +# It has to be at the project root, otherwise HIE will not resolve it properly. +cradle: + cabal: + cabalProject: "cabal.project.self-debug-test" + component: "all" diff --git a/hie-self-debug.yaml b/hie-self-debug.yaml new file mode 100644 index 00000000..5a702030 --- /dev/null +++ b/hie-self-debug.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "all" diff --git a/hie.yaml b/hie.yaml index de918f89..00929134 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,9 +1,8 @@ cradle: cabal: - component: "all" - # - path: "./haskell-debugger/" - # component: "lib:haskell-debugger" - # - path: "./hdb/" - # component: "exe:hdb" - # - path: "./test/haskell/" - # component: "test:haskell-debugger-test" + - path: "./haskell-debugger/" + component: "lib:haskell-debugger" + - path: "./hdb/" + component: "exe:hdb" + - path: "./test/haskell/" + component: "test:haskell-debugger-test" diff --git a/test/golden/self-debug-cli/hie.yaml b/test/golden/self-debug-cli/hie.yaml new file mode 100644 index 00000000..5a702030 --- /dev/null +++ b/test/golden/self-debug-cli/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "all" diff --git a/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test index 8514e551..8b87d67d 100644 --- a/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test +++ b/test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.hdb-test @@ -19,13 +19,18 @@ # # 5) When testing the sdist (just the packaged things), the root doesn't have a hie.yaml. # Add one temporarily + +# Dedicated HIE file for self-debug tests. + +yaml_file=hie-self-debug-test.yaml + created_yaml=false -if [ ! -f hie.yaml ]; then - echo 'cradle:\n cabal:\n component: "all"' > hie.yaml +if [ ! -f "$yaml_file" ]; then + printf 'cradle:\n cabal:\n component: "all"\n' > "$yaml_file" created_yaml=true; fi -$HDB -v0 hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \ +$HDB -v0 --cradle-file="$yaml_file" hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>&1 \ | grep -v "BreakFound" \ | grep -v "] Compiling" \ | sed \ @@ -34,5 +39,5 @@ $HDB -v0 hdb/Main.hs < "test/golden/self-debug-cli/self-debug-cli.hdb-stdin" 2>& -e 's|haskell-debugger-view-[0-9.][0-9.]*-inplace|haskell-debugger-view--inplace|g' if [ $created_yaml = true ]; then - rm hie.yaml + rm "$yaml_file" fi diff --git a/test/haskell/Test/DAP.hs b/test/haskell/Test/DAP.hs index ead437a2..0c96e87c 100644 --- a/test/haskell/Test/DAP.hs +++ b/test/haskell/Test/DAP.hs @@ -125,6 +125,7 @@ data LaunchConfig = LaunchConfig , lcEntryPoint :: Maybe String , lcEntryArgs :: [String] , lcExtraGhcArgs :: [String] + , lcCradleFile :: Maybe FilePath , lcInternalInterpreter :: Maybe Bool } @@ -137,6 +138,7 @@ mkLaunchConfig projectRoot entryFile = LaunchConfig , lcEntryPoint = Just "main" , lcEntryArgs = [] , lcExtraGhcArgs = [] + , lcCradleFile = Nothing , lcInternalInterpreter = Nothing } @@ -150,8 +152,10 @@ launchWith LaunchConfig{..} = launch $ object $ [ "entryPoint" .= ep | Just ep <- [lcEntryPoint] ] ++ [ "entryArgs" .= lcEntryArgs ] ++ [ "extraGhcArgs" .= lcExtraGhcArgs ] ++ + [ "cradleFile" .= file | Just file <- [lcCradleFile] ] ++ [ "internalInterpreter" .= b | Just b <- [lcInternalInterpreter] ] + -- | Set breakpoints in a particular source file of a project at the given -- lines. setLineBreakpoints :: FilePath -- ^ project root diff --git a/test/haskell/Test/Integration/Basic.hs b/test/haskell/Test/Integration/Basic.hs index eb925749..69c8241c 100644 --- a/test/haskell/Test/Integration/Basic.hs +++ b/test/haskell/Test/Integration/Basic.hs @@ -81,6 +81,7 @@ minimalConfig = , lcEntryArgs = [] , lcExtraGhcArgs = [] , lcInternalInterpreter = Nothing + , lcCradleFile = Nothing } hitBreakpointWith cfg 2 disconnect diff --git a/test/haskell/Test/Integration/SelfDebug.hs b/test/haskell/Test/Integration/SelfDebug.hs index ee38ce2d..6a79b094 100644 --- a/test/haskell/Test/Integration/SelfDebug.hs +++ b/test/haskell/Test/Integration/SelfDebug.hs @@ -32,8 +32,9 @@ selfDebugDAPTest = do doesFileExist (test_dir "cabal.project") >>= \exists -> unless exists $ writeFile (test_dir "cabal.project") "packages: . haskell-debugger-view\nallow-newer: ghc-bignum,containers,time,ghc,base,template-haskell" - doesFileExist (test_dir "hie.yaml") >>= \exists -> - unless exists $ writeFile (test_dir "hie.yaml") + let hieFileName = "hie-self-debug-test.yaml" + doesFileExist (test_dir hieFileName) >>= \exists -> + unless exists $ writeFile (test_dir hieFileName) "cradle:\n cabal:\n component: \"all\"" withTestDAPServerClient server $ do let cfg = LaunchConfig @@ -42,6 +43,7 @@ selfDebugDAPTest = do , lcEntryPoint = Just "main" , lcEntryArgs = ["cli", "test/golden/self-debug-cli/Main.hs"] , lcExtraGhcArgs = [] + , lcCradleFile = Just hieFileName , lcInternalInterpreter = Nothing }