Add cache dirs for compiler artefacts

.gitignore

@@ -1,6 +1,7 @@
 *.bkp
 .vscode/
 node_modules/
+test/integration-tests/out/
 vscode-extension/dist/
 vscode-extension/result
 dist-newstyle/

haskell-debugger.cabal

@@ -76,6 +76,8 @@ library
                       directory >= 1.3.9.0 && < 1.4,
                       exceptions >= 0.10.9 && < 0.11,
                       bytestring >= 0.12.1 && < 0.13,
+                      cryptohash-sha1,
+                      base16-bytestring,
                       aeson >= 2.2.3 && < 2.3,
                       hie-bios >= 0.15 && < 0.18
 
@@ -110,6 +112,7 @@ executable hdb
         implicit-hie ^>=0.1.4.0,
         transformers,
 
+        time,
         directory >= 1.3.9 && < 1.4,
         async >= 2.2.5 && < 2.3,
         text >= 2.1 && < 2.3,

haskell-debugger/GHC/Debugger/Monad.hs

@@ -1,4 +1,12 @@
-{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, NamedFieldPuns, TupleSections, LambdaCase, OverloadedRecordDot, TypeApplications #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
 module GHC.Debugger.Monad where
 
 import Prelude hiding (mod)
@@ -24,7 +32,7 @@
 import GHC.Runtime.Interpreter as GHCi
 import GHC.Runtime.Heap.Inspect
 import GHC.Unit.Module.Env as GHC
 import GHC.Runtime.Debugger.Breakpoints
 import GHC.Driver.Env
 
 import Data.IORef
@@ -108,15 +116,12 @@
             -> IO a
 runDebugger dbg_out rootDir compDir libdir units ghcInvocation' mainFp conf (Debugger action) = do
   let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'
-
   GHC.runGhc (Just libdir) $ do
     -- Workaround #4162
     _ <- liftIO $ installHandler sigINT Default Nothing
     dflags0 <- GHC.getSessionDynFlags
-
     let dflags1 = dflags0
           { GHC.ghcMode = GHC.CompManager
-          , GHC.backend = GHC.interpreterBackend
           , GHC.ghcLink = GHC.LinkInMemory
           , GHC.verbosity = 1
           , GHC.canUseColor = conf.supportsANSIStyling
@@ -128,6 +133,8 @@
           `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges
           `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects
           `GHC.gopt_set` GHC.Opt_InsertBreakpoints
+          & setBytecodeBackend
+          & enableByteCodeGeneration
 
     GHC.modifyLogger $
       -- Override the logger to output to the given handle
@@ -163,6 +170,7 @@
 
     runReaderT action =<< initialDebuggerState
 
+
 -- | The logger action used to log GHC output
 debuggerLoggerAction :: Handle -> LogAction
 debuggerLoggerAction h a b c d = do

haskell-debugger/GHC/Debugger/Session.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DerivingStrategies, CPP #-}
+{-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-}
 
 -- | Initialise the GHC session for one or more home units.
 --
@@ -10,11 +10,31 @@
   TargetDetails(..),
   Target(..),
   toGhcTarget,
+  CacheDirs(..),
+  getCacheDirs,
+  -- * DynFlags modifications
+  setWorkingDirectory,
+  setCacheDirs,
+  setBytecodeBackend,
+  enableByteCodeGeneration,
   )
   where
 
 import Control.Monad
 import Control.Monad.IO.Class
+import qualified Crypto.Hash.SHA1                    as H
+import qualified Data.ByteString.Base16              as B16
+import qualified Data.ByteString.Char8               as B
+import Data.Function
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Map as Map
+import qualified Data.List as L
+import qualified Data.Containers.ListUtils as L
+import GHC.ResponseFile (expandResponse)
+import HIE.Bios.Environment as HIE
+import System.FilePath
+import qualified System.Directory as Directory
+import qualified System.Environment as Env
 
 import qualified GHC
 import GHC.Driver.DynFlags as GHC
@@ -30,14 +50,6 @@
 import GHC.Types.SrcLoc
 import Language.Haskell.Syntax.Module.Name
 
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Map as Map
-import qualified Data.List as L
-import qualified Data.Containers.ListUtils as L
-import GHC.ResponseFile (expandResponse)
-import HIE.Bios.Environment as HIE
-import System.FilePath
-
 -- | Throws if package flags are unsatisfiable
 parseHomeUnitArguments :: GhcMonad m
     => FilePath -- ^ Main entry point function
@@ -80,13 +92,16 @@
           initOne args
       initOne this_opts = do
         (dflags', targets') <- addCmdOpts this_opts dflags
-
         let targets = HIE.makeTargetsAbsolute root targets'
             root = case workingDirectory dflags' of
               Nothing   -> compRoot
               Just wdir -> compRoot </> wdir
+        cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts
         let dflags'' =
               setWorkingDirectory root $
+              setCacheDirs cacheDirs $
+              enableByteCodeGeneration $
+              setBytecodeBackend $
               makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory
               dflags'
         return (dflags'', targets)
@@ -228,9 +243,78 @@
 hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv
 hscSetUnitEnv ue env = env { hsc_unit_env = ue }
 
+-- ----------------------------------------------------------------------------
+-- Session cache directory
+-- ----------------------------------------------------------------------------
+
+data CacheDirs = CacheDirs
+  { hiCacheDir :: FilePath
+  , byteCodeCacheDir :: FilePath
+  , hieCacheDir :: FilePath
+  , objCacheDir :: FilePath
+  }
+
+getCacheDirs :: String -> [String] -> IO CacheDirs
+getCacheDirs prefix opts = do
+  mCacheDir <- Env.lookupEnv "HDB_CACHE_DIR"
+  rootDir <- case mCacheDir of
+    Just dir -> pure dir
+    Nothing ->
+      Directory.getXdgDirectory Directory.XdgCache "hdb"
+  let sessionCacheDir = rootDir </> prefix ++ "-" ++ opts_hash
+  Directory.createDirectoryIfMissing True sessionCacheDir
+  pure CacheDirs
+    { hiCacheDir = sessionCacheDir
+    , byteCodeCacheDir = sessionCacheDir
+    , hieCacheDir = sessionCacheDir
+    , objCacheDir = sessionCacheDir
+    }
+  where
+    -- Create a unique folder per set of different GHC options, assuming that each different set of
+    -- GHC options will create incompatible interface files.
+    opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)
+
+-- ----------------------------------------------------------------------------
+-- Modification of DynFlags
+-- ----------------------------------------------------------------------------
+
 setWorkingDirectory :: FilePath -> DynFlags -> DynFlags
 setWorkingDirectory p d = d { workingDirectory =  Just p }
 
+setCacheDirs :: CacheDirs -> DynFlags -> DynFlags
+setCacheDirs CacheDirs{..} flags = flags
+  { hiDir = Just hiCacheDir
+  , hieDir = Just hieCacheDir
+  , objectDir = Just objCacheDir
+#if MIN_VERSION_ghc(9,14,2)
+  , bytecodeDir = Just byteCodeCacheDir
+#endif
+  }
+
+-- | If the compiler supports `.gbc` files (>= 9.14.2), then persist these
+-- artefacts to disk.
+enableByteCodeGeneration :: DynFlags -> DynFlags
+enableByteCodeGeneration dflags =
+#if MIN_VERSION_ghc(9,14,2)
+  dflags
+    & flip gopt_unset Opt_ByteCodeAndObjectCode
+    & flip gopt_set Opt_ByteCode
+    & flip gopt_set Opt_WriteByteCode
+    & flip gopt_set Opt_WriteInterface
+#else
+  dflags
+#endif
+
+setBytecodeBackend :: DynFlags -> DynFlags
+setBytecodeBackend dflags = dflags
+  {
+#if MIN_VERSION_ghc(9,14,2)
+  backend = GHC.bytecodeBackend
+#else
+  backend = GHC.interpreterBackend
+#endif
+  }
+
 -- ----------------------------------------------------------------------------
 -- Utils that we need, but don't want to incur an additional dependency for.
 -- ----------------------------------------------------------------------------

hdb/Development/Debug/Adapter/Logger.hs

@@ -7,24 +7,35 @@ module Development.Debug.Adapter.Logger (
   Severity (..),
   WithSeverity (..),
   cmap,
+  cmapIO,
   cmapWithSev,
 
   -- * Pretty printing of logs
   renderPrettyWithSeverity,
   renderWithSeverity,
   renderPretty,
   renderSeverity,
+  renderWithTimestamp,
 ) where
 
+import Control.Monad.IO.Class
+import Control.Monad ((>=>))
 import Colog.Core (LogAction (..), Severity (..), WithSeverity (..))
 import Colog.Core.Action (cmap)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Prettyprinter
 import Prettyprinter.Render.Text (renderStrict)
+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
 
 cmapWithSev :: (a -> b) -> LogAction m (WithSeverity b) -> LogAction m (WithSeverity a)
 cmapWithSev f = cmap (fmap f)
 
+cmapIO :: MonadIO m => (a -> IO b) -> LogAction m b -> LogAction m a
+cmapIO f LogAction{ unLogAction } =
+  LogAction
+    { unLogAction = (liftIO . f) >=> unLogAction }
+
 renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text
 renderPrettyWithSeverity =
   renderWithSeverity renderPretty
@@ -40,6 +51,14 @@ renderPretty a =
   in
     docToText (pretty a)
 
+renderWithTimestamp :: Text -> IO Text
+renderWithTimestamp msg = do
+  t <- getCurrentTime
+  let timeStamp = utcTimeToText t
+  pure $ "[" <> timeStamp <> "]" <> msg
+  where
+    utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime
+
 renderSeverity :: Severity -> Text
 renderSeverity = \ case
   Debug -> "[DEBUG]"

hdb/Main.hs

@@ -23,7 +23,6 @@
 import qualified Data.Text.IO as T
 import GHC.IO.Handle.FD
 
-
 defaultStdoutForwardingAction :: T.Text -> IO ()
 defaultStdoutForwardingAction line = do
   T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> line)
@@ -37,8 +36,10 @@
   withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do
     hSetBuffering realStdout LineBuffering
     l <- handleLogger realStdout
-    let loggerWithSev = cmap (renderWithSeverity id) l
-    runDAPServerWithLogger (cmap renderDAPLog l) config (talk loggerWithSev)
+    let
+      timeStampLogger = cmapIO renderWithTimestamp l
+      loggerWithSev = cmap (renderWithSeverity id) timeStampLogger
+    runDAPServerWithLogger (cmap renderDAPLog timeStampLogger) config (talk loggerWithSev)
 
 -- | Fetch config from environment, fallback to sane defaults
 getConfig :: Int -> IO ServerConfig
@@ -94,7 +95,7 @@
 -- is implemented in this function.
 talk :: LogAction IO (WithSeverity T.Text) -> Command -> DebugAdaptor ()
 --------------------------------------------------------------------------------
 talk l = \ case
   CommandInitialize -> do
     -- InitializeRequestArguments{..} <- getArguments
     sendInitializeResponse

test/integration-tests/.mocharc.json

@@ -0,0 +1,5 @@
+{
+  "extension": ["ts"],
+  "spec": "test/**/*.test.ts",
+  "require": "ts-node/register"
+}

test/integration-tests/Makefile

@@ -2,16 +2,16 @@ all: test
 
 .PHONY: clean test
 
-node := $(shell nix-shell -p nodejs --run 'which node')
+node := $(shell nix develop --command bash -c "which node")
 
 clean:
 	rm -rf ./node_modules
 
 node_modules:
-	nix-shell -p 'nodejs' --run 'npm install'
+	nix develop --command bash -c "npm install && npm run compile"
 
 test: node_modules
 	# PATH=$(dir $(GHC)):$(dir $(DEBUGGER)):$$PATH ./node_modules/.bin/mocha -f 'allow arbitrarily deep'
 	# nix-shell -p nodejs --run 'PATH=$(dir $(GHC)):$(dir $(DEBUGGER)):$$PATH ./node_modules/.bin/mocha'
 	@echo "NODE: $(node)"
-	PATH=$(dir $(GHC)):$(dir $(DEBUGGER)):$(dir $(node)):$$PATH ./node_modules/.bin/mocha --parallel
+	nix develop --command bash -c "PATH=$(dir $(GHC)):$(dir $(DEBUGGER)):$(dir $(node)):$$PATH npm run test"