haskell-debug-adapter 0.0.41.0 → 0.0.42.0
raw patch · 4 files changed
+173/−29 lines, 4 filesdep +fsnotifydep +hie-biosPVP ok
version bump matches the API change (PVP)
Dependencies added: fsnotify, hie-bios
API changes (from Hackage documentation)
Files
- Changelog.md +4/−0
- haskell-debug-adapter.cabal +9/−8
- src/Haskell/Debug/Adapter/State/Init/Launch.hs +70/−21
- src/Haskell/Debug/Adapter/Watch.hs +90/−0
Changelog.md view
@@ -1,3 +1,7 @@+20250316 haskell-debug-adapter-0.0.42.0+ * [PR] Use hie-bios to generalize build command #37++ 20250209 haskell-debug-adapter-0.0.41.0 * [MODIFY] Improved debug console output.
haskell-debug-adapter.cabal view
@@ -1,13 +1,11 @@ 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+version: 0.0.42.0 synopsis: Haskell Debug Adapter. description: Please see README.md category: Development@@ -55,7 +53,7 @@ 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 @@ , 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 @@ , 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 @@ , 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
src/Haskell/Debug/Adapter/State/Init/Launch.hs view
@@ -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 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 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 @@ -- 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,39 +134,81 @@ 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+ isExist <- U.liftIOE $ D.doesFileExist startup_file+ when (False == isExist) $ do+ U.sendErrorEventLF $ "file not found. [" ++ startup_file ++ "]"+ -- throwError $ "file not found. [" ++ startup_file ++ "]"++ 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 U.debugEV _LOG_APP $ "GHCi version is " ++ V.showVersion v@@ -226,12 +275,16 @@ 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 +293,6 @@ return () ---- |--- addWithGHC :: [String] -> AppContext [String] addWithGHC [] = return [] addWithGHC cmds@@ -259,7 +309,6 @@ withGhciExists (x:xs) | L.isPrefixOf "--with-ghc=" x = True | otherwise = withGhciExists xs- -- | --
+ src/Haskell/Debug/Adapter/Watch.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}++module Haskell.Debug.Adapter.Watch where++import Control.Monad.IO.Class+import qualified System.FSNotify as S+import Control.Lens+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar+import Control.Monad.State.Lazy+import qualified System.Log.Logger as L+import Control.Monad.Except+import qualified Data.List as L++import Haskell.Debug.Adapter.Type+import Haskell.Debug.Adapter.Utility+import Haskell.Debug.Adapter.Constant++import System.FilePath++#if __GLASGOW_HASKELL__ >= 906+import Control.Monad+#endif+-- |+--+run :: AppStores -> IO ()+run appData = do+ L.debugM _LOG_WATCH "start watch app"+ _ <- runApp appData app+ L.debugM _LOG_WATCH "end watch app"+++-- |+--+app :: AppContext ()+app = flip catchError errHdl $ do+ liftIO $ L.infoM _LOG_WATCH "wait getting workspace path."+ ws <- getWS+ liftIO $ L.infoM _LOG_WATCH $ "start watching " ++ ws++ reqStore <- view reqStoreAppStores <$> get+ let conf = S.defaultConfig+ liftIO $ S.withManagerConf conf $ goIO ws reqStore+ + where+ -- |+ --+ errHdl msg = do+ criticalEV _LOG_REQUEST msg+ addEvent CriticalExitEvent++ -- |+ --+ goIO ws reqStore mgr = do+ S.watchTree mgr ws hsFilter (action reqStore)+ forever $ threadDelay _1_SEC++ -- |+ --+ hsFilter ev = (L.isSuffixOf _HS_FILE_EXT (S.eventPath ev))+ && (not (L.isInfixOf (pathSeparator:".") (S.eventPath ev)))++ -- |+ --+ action mvar ev@(S.Added{}) = sendRequest mvar ev+ action mvar ev@(S.Modified{}) = sendRequest mvar ev+ action _ _ = return ()++ -- |+ --+ sendRequest mvar ev = do+ L.debugM _LOG_WATCH $ "detect. " ++ show ev+ let req = WrapRequest $ InternalLoadRequest + $ HdaInternalLoadRequest $ S.eventPath ev+ reqs <- takeMVar mvar+ putMVar mvar (req : reqs)+ ++ -- |+ -- + getWS :: AppContext FilePath+ getWS = do+ wsMVar <- view workspaceAppStores <$> get+ ws <- liftIO $ readMVar wsMVar+ if not (null ws) then return ws+ else do+ liftIO $ threadDelay _1_SEC+ getWS+