Use hie-bios to generalize build command (#37)

* Use hie-bios to generalize build command

Currently, HDA determines how to run ghci for any given project by
getting runCmd from the client.

Even though the VSCode extension and others set a default scaffolding
for either stack or cabal projects, this approach has a few
shortcomings:

1. Newish Haskell users are not well versed in the build systems so they
   can't work around failures to invoke the commands as specified

2. Other build systems or even simple Haskell programs that are not a
   package at all cannot benefit from HDA.

    - For example, GHC uses the hadrian build system.
    - Users new to Haskell don't use cabal nor stack straight away, but
      could benefit from step by step execution of their program

Luckily, the hie-bios project aims to solve exactly this problem of
determining how to invoke GHC for any given Haskell project and supports
a wide range of different tools. It also allows users to be very precise
about their own build set up by reading a hie.yaml configuration.

haskell-language-server already uses this approach: call functions from
hie-bios to determine how to invoke ghc.

This commit does the same for HDA, to make it more robust across
different Haskell projects.

Manually tested on:
- GHC (custom hie.yaml)
- fast-tags (Cabal package)
- Simple Main.hs file with 1 dependency

* Only enable hie-bios when cmd=ghci-dap

Re-introduce stack and cabal based debugging sessions.
Now, hie-bios will only be used if the ghciCmd in launch.json is exactly
"ghci-dap"

This allows hie-bios workflows to co-exist with the remaining ones,
serving as a safety net if something goes wrong.

Author: alt-romes

haskell-debug-adapter.cabal

@@ -1,10 +1,8 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.37.0.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: 31df6f8a3983d139dd38dfb23e6a70668fe0e158220e5b7a993db5050d161c30
 
 name:           haskell-debug-adapter
 version:        0.0.41.0
@@ -55,7 +53,7 @@ library
       Haskell.Debug.Adapter.TH.Utility
       Haskell.Debug.Adapter.Type
       Haskell.Debug.Adapter.Utility
-      -- Haskell.Debug.Adapter.Watch
+      Haskell.Debug.Adapter.Watch
       Paths_haskell_debug_adapter
   hs-source-dirs:
       src
@@ -111,9 +109,10 @@ library
     , data-default
     , directory
     , filepath
-    -- , fsnotify
+    , fsnotify
     , ghci-dap >=0.0.23.0
     , haskell-dap >=0.0.16.0
+    , hie-bios >=0.13
     , hslogger
     , lens
     , mtl
@@ -185,10 +184,11 @@ executable haskell-debug-adapter
     , data-default
     , directory
     , filepath
-    -- , fsnotify
+    , fsnotify
     , ghci-dap >=0.0.23.0
     , haskell-dap >=0.0.16.0
     , haskell-debug-adapter
+    , hie-bios >=0.13
     , hslogger
     , lens
     , mtl
@@ -263,10 +263,11 @@ test-suite haskell-debug-adapter-test
     , data-default
     , directory
     , filepath
-    -- , fsnotify
+    , fsnotify
     , ghci-dap >=0.0.23.0
     , haskell-dap >=0.0.16.0
     , haskell-debug-adapter
+    , hie-bios >=0.13
     , hslogger
     , hspec
     , lens

package.yaml

@@ -92,6 +92,7 @@ dependencies:
 - optparse-applicative
 - haskell-dap >=0.0.16.0
 - ghci-dap >=0.0.23.0
+- hie-bios >=0.13
 
 library:
   source-dirs: src

src/Haskell/Debug/Adapter/State/Init/Launch.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Haskell.Debug.Adapter.State.Init.Launch where
 
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Except
 import Control.Monad.State
@@ -14,6 +17,7 @@ import qualified System.Log.Logger as L
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.List as L
 import qualified Data.Version as V
+import qualified System.Directory as D
 
 import qualified Haskell.DAP as DAP
 import qualified Haskell.Debug.Adapter.Utility as U
@@ -23,6 +27,9 @@ import Haskell.Debug.Adapter.Constant
 import qualified Haskell.Debug.Adapter.Logger as L
 import qualified Haskell.Debug.Adapter.GHCi as P
 
+import qualified HIE.Bios as HIE
+import qualified HIE.Bios.Types as HIE
+import qualified HIE.Bios.Environment as HIE
 
 -- |
 --   Any errors should be critical. don't catch anything here.
@@ -48,11 +55,11 @@ app req = flip catchError errHdl $ do
 
   -- must start here. can not start in the entry of GHCiRun State.
   -- because there is a transition from DebugRun to GHCiRun.
-  startGHCi req
+  flags <- startGHCi req
   setPrompt
   launchCmd req
   setMainArgs
-  loadStarupFile
+  loadStarupFile flags
 
   -- dont send launch response here.
   -- it must send after configuration done response.
@@ -127,38 +134,75 @@ setUpLogger req = do
   liftIO $ L.setUpLogger (DAP.logFileLaunchRequestArguments args) logPR
 
 
--- |
---
-startGHCi :: DAP.LaunchRequest -> AppContext ()
+-- | Starts GHCi and returns the list of arguments it passed to invoke it.
+startGHCi :: DAP.LaunchRequest -> AppContext [String]
 startGHCi req = do
   let args = DAP.argumentsLaunchRequest req
       initPmpt = maybe _GHCI_PROMPT id (DAP.ghciInitialPromptLaunchRequestArguments args)
       envs = DAP.ghciEnvLaunchRequestArguments args
-      cmdStr = DAP.ghciCmdLaunchRequestArguments args
-      cmdList = filter (not.null) $ U.split " " cmdStr
-      cmd  = head cmdList
 
-  U.debugEV _LOG_APP $ show cmdList
+      -- Ignore ghciCmd LaunchRequestArguments
+      -- Instead, use `hie-bios` to do the Right Thing across projects without complicated user input.
+      -- Eventually, get rid of this option from haskell-dap.
+      cmdStr = DAP.ghciCmdLaunchRequestArguments args
+      (cmd:cmdOpts) = filter (not.null) $ U.split " " cmdStr
 
-  opts <- addWithGHC (tail cmdList)
+      startup_file = DAP.startupLaunchRequestArguments args
 
   appStores <- get
   cwd <- U.liftIOE $ readMVar $ appStores^.workspaceAppStores
 
+  -- Use hie-bios when Cmd is exactly "ghci-dap"
+  flags <- if cmdStr /= "ghci-dap" then addWithGHC cmdOpts else do
+    explicitCradle <- U.liftIOE $ HIE.findCradle startup_file
+    cradle <- U.liftIOE $ maybe (HIE.loadImplicitCradle mempty startup_file)
+                                (HIE.loadCradle mempty) explicitCradle
+
+    libdir <- U.liftIOE (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir"
+
+    -- getCompilerOptions depends on CWD being the proper root dir.
+    let compilerOpts = D.withCurrentDirectory cwd $
+#if MIN_VERSION_hie_bios(0,14,0)
+                          HIE.getCompilerOptions startup_file HIE.LoadFile cradle
+#else
+                          HIE.getCompilerOptions startup_file [] cradle
+#endif
+    HIE.ComponentOptions {HIE.componentOptions = flags} <- U.liftIOE compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle"
+
+    return $
+#if __GLASGOW_HASKELL__ >= 913
+      -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading
+      ["-fwrite-if-simplified-core"] ++
+#endif
+      ["--interactive", "-B"++libdir] ++ flags
+
+  U.debugEV _LOG_APP $ show flags
+
   U.liftIOE $ L.debugM _LOG_APP $ "ghci initial prompt [" ++ initPmpt ++ "]."
 
   U.sendConsoleEventLF $ "CWD: " ++ cwd
-  U.sendConsoleEventLF $ "CMD: " ++ L.intercalate " " (cmd : opts)
+  U.sendConsoleEventLF $ "CMD: " ++ L.intercalate " " (cmd:flags)
   U.sendConsoleEventLF ""
 
-  P.startGHCi cmd opts cwd envs
+  P.startGHCi cmd flags cwd envs
+
   U.sendErrorEventLF $ "Now, waiting for an initial prompt(\""++initPmpt++"\")" ++ " from ghci."
   U.sendConsoleEventLF ""
   res <- P.expectInitPmpt initPmpt
 
   updateGHCiVersion res
 
+  return flags
+
   where
+    unwrapCradleResult m = \case
+      HIE.CradleNone     -> panic (error m) "HIE.CradleNone"
+      HIE.CradleFail err -> panic (error m) (unlines $ HIE.cradleErrorStderr err)
+      HIE.CradleSuccess x -> return x
+
+    panic exit m = do
+      U.sendErrorEvent m
+      exit
 
     updateGHCiVersion acc = case parse verParser "getGHCiVersion" (unlines acc) of
       Right v -> do
@@ -226,12 +270,16 @@ setMainArgs = view mainArgsAppStores <$> get >>= \case
     return ()
 
 
--- |
---
-loadStarupFile :: AppContext ()
-loadStarupFile = do
+-- | Takes as an argument the list of flags used to invoke GHCi to determine
+-- if the main module has already been loaded. If it hasn't, loads the main file.
+loadStarupFile :: [String] -> AppContext ()
+loadStarupFile flags = do
   file <- view startupAppStores <$> get
-  SU.loadHsFile file
+  when (not $ any (\lf -> lf `L.isSuffixOf` file) flags) $
+    -- We only load the file if it hasn't already been given as an argument;
+    -- Otherwise, we'll force loading the main module and all of its dependencies a second time.
+    -- That is incredibly painful in large projects (like GHC).
+    SU.loadHsFile file
 
   let cmd  = ":dap-context-modules "
 
@@ -240,9 +288,6 @@ loadStarupFile = do
 
   return ()
 
-
--- |
---
 addWithGHC :: [String] -> AppContext [String]
 addWithGHC [] = return []
 addWithGHC cmds
@@ -260,7 +305,6 @@ addWithGHC cmds
       | L.isPrefixOf "--with-ghc=" x = True
       | otherwise = withGhciExists xs
 
-
 -- |
 --
 _TASKS_JSON_FILE_CONTENTS :: LB.ByteString

stack.yaml

@@ -18,8 +18,11 @@
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
 
+# for ghc-9.10
+resolver: nightly-2025-02-28
+
 # for ghc-9.0.1
-resolver: nightly-2021-07-02
+# resolver: nightly-2021-07-02
 
 # for ghc-8.10.3
 # resolver: lts-17.0