diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for breakpoint +## 0.1.4.0 -- 2024-02-25 +* Support GHC 9.10.x +* Drop support for 9.2 + ## 0.1.3.1 -- 2024-02-25 * Bump `ansi-terminal` bounds diff --git a/breakpoint.cabal b/breakpoint.cabal --- a/breakpoint.cabal +++ b/breakpoint.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: breakpoint -version: 0.1.3.1 +version: 0.1.4.0 synopsis: Set breakpoints using a GHC plugin @@ -13,7 +13,7 @@ license-file: LICENSE author: Aaron Allen maintainer: aaronallen8455@gmail.com -tested-with: GHC==9.8.1, GHC==9.6.1, GHC==9.4.2, GHC==9.2.2 +tested-with: GHC==9.10.1, GHC==9.8.1, GHC==9.6.1, GHC==9.4.2 bug-reports: https://github.com/aaronallen8455/breakpoint/issues -- A copyright notice. @@ -29,19 +29,20 @@ -- Modules included in this library but not exported. other-modules: Debug.Breakpoint.Renamer, - Debug.Breakpoint.TypeChecker + Debug.Breakpoint.TypeChecker, + Debug.Breakpoint.TimerManager.Names -- LANGUAGE extensions used by modules in this package. -- other-extensions: - build-depends: base >= 4.16.0.0 && < 4.20.0.0, - ghc >= 9.2.0 && < 9.9, - containers >= 0.6.5 && < 0.7, + build-depends: base >= 4.16.0.0 && < 4.21.0.0, + ghc >= 9.4.0 && < 9.11, + containers >= 0.6.5 && < 0.8, mtl >= 2.2.2 && < 2.4, transformers >= 0.5.6 && < 0.7, haskeline >= 0.8.2 && < 0.9, pretty-simple >= 4.1.2 && < 4.2, text >= 1.2.5 && < 2.2, - template-haskell >= 2.18.0 && < 2.22, + template-haskell >= 2.18.0 && < 2.23, ansi-terminal >= 1.0 && < 2.0, deepseq >= 1.0 && < 1.6 hs-source-dirs: src diff --git a/src/Debug/Breakpoint/GhcFacade.hs b/src/Debug/Breakpoint/GhcFacade.hs --- a/src/Debug/Breakpoint/GhcFacade.hs +++ b/src/Debug/Breakpoint/GhcFacade.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} module Debug.Breakpoint.GhcFacade @@ -15,8 +16,6 @@ , findImportedModule' , findPluginModule' , pattern HsLet' - , pattern LetStmt' - , pattern ExplicitList' , pattern OverLit' , pattern CDictCan' ) where @@ -32,6 +31,7 @@ import GHC.Types.Name as Ghc import GHC.Iface.Env as Ghc import GHC.Unit.Finder as Ghc +import GHC.Unit.Types as Ghc import GHC.Tc.Utils.Monad as Ghc hiding (TcPlugin, DefaultingPlugin) import GHC.Data.FastString as Ghc import GHC.Hs.Utils as Ghc @@ -41,6 +41,7 @@ import GHC.Data.Bag as Ghc import GHC.Types.Basic as Ghc import GHC.Types.Name.Env as Ghc +import GHC.Builtin.Names as Ghc import GHC.Builtin.Types as Ghc import GHC.Core.TyCo.Rep as Ghc import GHC.Tc.Types.Constraint as Ghc @@ -68,6 +69,7 @@ import GHC.Types.Name as Ghc import GHC.Iface.Env as Ghc import GHC.Unit.Finder as Ghc +import GHC.Unit.Types as Ghc import GHC.Unit.Module.Name as Ghc import GHC.Tc.Utils.Monad as Ghc hiding (TcPlugin, DefaultingPlugin) import GHC.Data.FastString as Ghc @@ -78,6 +80,7 @@ import GHC.Data.Bag as Ghc import GHC.Types.Basic as Ghc import GHC.Types.Name.Env as Ghc +import GHC.Builtin.Names as Ghc import GHC.Builtin.Types as Ghc import GHC.Core.TyCo.Rep as Ghc import GHC.Tc.Types.Constraint as Ghc @@ -94,42 +97,6 @@ import GHC.Types.PkgQual as Ghc import GHC.Tc.Types.Origin as Ghc -#elif MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Plugins as Ghc hiding (TcPlugin) -import GHC.Hs.Extension as Ghc -import Language.Haskell.Syntax as Ghc -import GHC.Tc.Types as Ghc -import qualified GHC.Tc.Plugin as Plugin -import GHC.Parser.Annotation as Ghc -import GHC.Types.SrcLoc as Ghc -import GHC.Types.Name as Ghc -import GHC.Iface.Env as Ghc -import GHC.Unit.Finder as Ghc -import GHC.Unit.Module.Name as Ghc -import GHC.Tc.Utils.Monad as Ghc hiding (TcPlugin) -import GHC.Data.FastString as Ghc -import GHC.Hs.Utils as Ghc -import GHC.Types.Unique.Set as Ghc -import GHC.Utils.Outputable as Ghc -import GHC.Hs.Binds as Ghc -import GHC.Data.Bag as Ghc -import GHC.Types.Basic as Ghc -import GHC.Types.Name.Env as Ghc -import GHC.Builtin.Types as Ghc -import GHC.Core.TyCo.Rep as Ghc -import GHC.Tc.Types.Constraint as Ghc -import GHC.Core.Make as Ghc -import GHC.Tc.Types.Evidence as Ghc -import GHC.Types.Id as Ghc -import GHC.Core.InstEnv as Ghc -import GHC.Core.Class as Ghc hiding (FunDep) -import GHC.Tc.Utils.TcType as Ghc -import GHC.Core.Type as Ghc -import GHC.Core.TyCon as Ghc -import GHC.Types.TyThing.Ppr as Ghc -import GHC.Hs.Expr as Ghc -import GHC.Tc.Types.Origin as Ghc - #endif liftedRepName :: Ghc.Name @@ -150,21 +117,16 @@ mkWildValBinder' = Ghc.mkWildValBinder Ghc.oneDataConTy pprTypeForUser' :: Ghc.Type -> Ghc.SDoc -#if MIN_VERSION_ghc(9,4,0) pprTypeForUser' = Ghc.pprSigmaType -#else -pprTypeForUser' = Ghc.pprTypeForUser -#endif showSDocOneLine' :: Ghc.SDoc -> String showSDocOneLine' = Ghc.showSDocOneLine Ghc.defaultSDocContext -findImportedModule' :: Ghc.ModuleName -> Ghc.TcPluginM Ghc.FindResult -#if MIN_VERSION_ghc(9,4,0) -findImportedModule' modName = Plugin.findImportedModule modName Ghc.NoPkgQual -#else -findImportedModule' modName = Plugin.findImportedModule modName Nothing -#endif +findImportedModule' :: Ghc.ModuleName -> Ghc.TcPluginM Module +findImportedModule' modName = + Plugin.findImportedModule modName Ghc.NoPkgQual >>= \case + Found _ m -> pure m + _ -> fail "Could not find module!" findPluginModule' :: Ghc.ModuleName -> Ghc.TcM Ghc.FindResult #if MIN_VERSION_ghc(9,4,0) @@ -176,75 +138,47 @@ liftIO $ Ghc.findPluginModule hscEnv modName #endif -#if MIN_VERSION_ghc(9,4,0) type LetToken = +#if MIN_VERSION_ghc(9,10,0) + () +#else Ghc.LHsToken "let" Ghc.GhcRn +#endif type InToken = - Ghc.LHsToken "in" Ghc.GhcRn +#if MIN_VERSION_ghc(9,10,0) + () #else -type LetToken = () -type InToken = () + Ghc.LHsToken "in" Ghc.GhcRn #endif pattern HsLet' :: Ghc.XLet Ghc.GhcRn -> LetToken - -> Ghc.Located (Ghc.HsLocalBinds Ghc.GhcRn) + -> Ghc.HsLocalBinds Ghc.GhcRn -> InToken -> Ghc.LHsExpr Ghc.GhcRn -> Ghc.HsExpr Ghc.GhcRn -#if MIN_VERSION_ghc(9,4,0) -pattern HsLet' x letToken lbinds inToken expr <- - Ghc.HsLet x letToken (Ghc.L Ghc.noSrcSpan -> lbinds) inToken expr - where - HsLet' x letToken (Ghc.L _ binds) inToken expr = - Ghc.HsLet x letToken binds inToken expr -#elif MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,10,0) +hsLetShim :: x -> (x, (), ()) +hsLetShim x = (x, (), ()) pattern HsLet' x letToken lbinds inToken expr <- - Ghc.HsLet (pure . pure -> (letToken, (inToken, x))) (Ghc.L Ghc.noSrcSpan -> lbinds) expr + Ghc.HsLet (hsLetShim -> (x, letToken, inToken)) lbinds expr where - HsLet' x () (Ghc.L _ binds) () expr = Ghc.HsLet x binds expr + HsLet' x () binds () expr = + Ghc.HsLet x binds expr #else pattern HsLet' x letToken lbinds inToken expr <- - Ghc.HsLet (pure . pure -> (letToken, (inToken, x))) lbinds expr - where - HsLet' x _ lbinds _ expr = Ghc.HsLet x lbinds expr -#endif - -pattern LetStmt' - :: XLetStmt Ghc.GhcRn Ghc.GhcRn body - -> Ghc.Located (HsLocalBinds Ghc.GhcRn) - -> Ghc.StmtLR Ghc.GhcRn Ghc.GhcRn body -#if MIN_VERSION_ghc(9,2,0) -pattern LetStmt' x lbinds <- - Ghc.LetStmt x (Ghc.L Ghc.noSrcSpan -> lbinds) - where - LetStmt' x (Ghc.L _ binds) = Ghc.LetStmt x binds -#else -pattern LetStmt' x lbinds = Ghc.LetStmt x lbinds -#endif - -pattern ExplicitList' - :: Ghc.XExplicitList p - -> [Ghc.LHsExpr p] - -> Ghc.HsExpr p -#if MIN_VERSION_ghc(9,2,0) -pattern ExplicitList' x exprs = Ghc.ExplicitList x exprs -#else -pattern ExplicitList' x exprs <- Ghc.ExplicitList x _ exprs + Ghc.HsLet x letToken lbinds inToken expr where - ExplicitList' x exprs = Ghc.ExplicitList x Nothing exprs + HsLet' x letToken binds inToken expr = + Ghc.HsLet x letToken binds inToken expr #endif pattern OverLit' :: Ghc.OverLitVal -> Ghc.HsOverLit Ghc.GhcRn pattern OverLit' lit -#if MIN_VERSION_ghc(9,4,0) <- Ghc.OverLit _ lit -#else - <- Ghc.OverLit _ lit _ -#endif pattern CDictCan' :: Ghc.CtEvidence diff --git a/src/Debug/Breakpoint/Renamer.hs b/src/Debug/Breakpoint/Renamer.hs --- a/src/Debug/Breakpoint/Renamer.hs +++ b/src/Debug/Breakpoint/Renamer.hs @@ -202,7 +202,7 @@ -> EnvReader (Maybe (Ghc.LHsExpr Ghc.GhcRn)) hsAppCase (Ghc.unLoc -> Ghc.HsApp _ f innerExpr) | Ghc.HsApp _ (Ghc.unLoc -> Ghc.HsVar _ (Ghc.unLoc -> name)) - (Ghc.unLoc -> Ghc.ExplicitList' _ exprsToExclude) + (Ghc.unLoc -> Ghc.ExplicitList _ exprsToExclude) <- Ghc.unLoc f = do MkEnv{..} <- lift ask @@ -329,12 +329,12 @@ -- TODO could combine with hsVar case to allow for "quick failure" hsLetCase :: Ghc.HsExpr Ghc.GhcRn -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn)) -hsLetCase (Ghc.HsLet' x letToken (Ghc.L loc localBinds) inToken inExpr) = do +hsLetCase (Ghc.HsLet' x letToken localBinds inToken inExpr) = do (bindsRes, names) <- dealWithLocalBinds localBinds inExprRes <- addScopedVars names $ recurse inExpr pure . Just $ - Ghc.HsLet' x letToken (Ghc.L loc bindsRes) inToken inExprRes + Ghc.HsLet' x letToken bindsRes inToken inExprRes hsLetCase _ = pure Nothing dealWithLocalBinds @@ -414,10 +414,10 @@ bodyRes <- lift $ recurse body pure $ Ghc.BindStmt x lpat bodyRes - Ghc.LetStmt' x (Ghc.L loc localBinds) -> do + Ghc.LetStmt x localBinds -> do (bindsRes, names) <- lift $ dealWithLocalBinds localBinds tell names - pure $ Ghc.LetStmt' x (Ghc.L loc bindsRes) + pure $ Ghc.LetStmt x bindsRes Ghc.ApplicativeStmt x pairs mbJoin -> do let dealWithAppArg = \case diff --git a/src/Debug/Breakpoint/TimerManager.hs b/src/Debug/Breakpoint/TimerManager.hs --- a/src/Debug/Breakpoint/TimerManager.hs +++ b/src/Debug/Breakpoint/TimerManager.hs @@ -15,7 +15,9 @@ import Control.Concurrent(rtsSupportsBoundThreads) import Control.Monad (when) +#if !MIN_VERSION_ghc(9,10,0) import Data.Foldable (foldl') +#endif import Data.IORef import Data.Word (Word64) import qualified GHC.Clock as Clock @@ -24,6 +26,8 @@ import Language.Haskell.TH.Syntax import System.IO.Unsafe +import Debug.Breakpoint.TimerManager.Names + -------------------------------------------------------------------------------- -- Hidden functions imported via TH -------------------------------------------------------------------------------- @@ -31,22 +35,22 @@ psqToList = $(pure $ VarE $ Name (OccName "toList") - (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ")) + (NameG VarName (PkgName pkgName) (ModName psqModName)) ) psqAdjust = $(pure $ VarE $ Name (OccName "adjust") - (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ")) + (NameG VarName (PkgName pkgName) (ModName psqModName)) ) psqKey = $(pure $ VarE $ Name (OccName "key") #if MIN_VERSION_ghc(9,8,0) - (NameG (FldName "E") (PkgName "base") (ModName "GHC.Event.PSQ")) + (NameG (FldName "E") (PkgName pkgName) (ModName psqModName)) #else - (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ")) + (NameG VarName (PkgName pkgName) (ModName psqModName)) #endif ) @@ -55,9 +59,9 @@ $(pure $ VarE $ Name (OccName "emTimeouts") #if MIN_VERSION_ghc(9,8,0) - (NameG (FldName "TimerManager") (PkgName "base") (ModName "GHC.Event.TimerManager")) + (NameG (FldName "TimerManager") (PkgName pkgName) (ModName timerManagerModName)) #else - (NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager")) + (NameG VarName (PkgName pkgName) (ModName timerManagerModName)) #endif ) @@ -65,49 +69,9 @@ wakeManager = $(pure $ VarE $ Name (OccName "wakeManager") - (NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager")) + (NameG VarName (PkgName pkgName) (ModName timerManagerModName)) ) --- Windows specific definitions --- #if defined(mingw32_HOST_OS) --- modifyDelay = --- $( do --- let delayName = Name (OccName "Delay") --- (NameG DataName (PkgName "base") (ModName "GHC.Conc.Windows")) --- --- matchDelay f = --- match (conP delayName [varP $ mkName "secs", varP $ mkName "mvar"]) body [] --- where --- body = normalB $ appsE [ conE delayName --- , appE (varE $ mkName "f") (varE $ mkName "secs") --- , varE $ mkName "mvar" --- ] --- --- delaySTMName = Name (OccName "DelaySTM") --- (NameG DataName (PkgName "base") (ModName "GHC.Conc.Windows")) --- --- matchDelaySTM f = --- match (conP delaySTMName [varP $ mkName "secs", varP $ mkName "tvar"]) body [] --- where --- body = normalB $ appsE [ conE delaySTMName --- , appE (varE $ mkName "f") (varE $ mkName "secs") --- , varE $ mkName "tvar" --- ] --- --- lamE [varP $ mkName "f", varP $ mkName "delay"] $ --- caseE (varE $ mkName "delay") --- [ matchDelay --- , matchDelaySTM --- ] --- ) --- --- pendingDelays = --- $(pure $ VarE $ --- Name (OccName "pendingDelays") --- (NameG VarName (PkgName "base") (ModName "GHC.Conc.Windows")) --- ) --- #endif - -------------------------------------------------------------------------------- -- Timeout editing -------------------------------------------------------------------------------- @@ -125,13 +89,6 @@ modifyTimeouts f = -- This only works for the threaded RTS when rtsSupportsBoundThreads $ do --- #if defined(mingw32_HOST_OS) --- -- Windows has its own way of tracking delays --- let modifyDelay = \case --- Delay x y -> Delay (f x) y --- DelaySTM x y -> DelaySTM (f x) y --- atomicModifyIORef'_ pendingDelays (fmap $ modifyDelay f) --- #else mgr <- getSystemTimerManager editTimeouts mgr $ \pq -> let els = psqToList pq diff --git a/src/Debug/Breakpoint/TimerManager/Names.hs b/src/Debug/Breakpoint/TimerManager/Names.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Breakpoint/TimerManager/Names.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +module Debug.Breakpoint.TimerManager.Names + ( psqModName + , timerManagerModName + , pkgName + ) where + +psqModName :: String +psqModName = +#if MIN_VERSION_ghc(9,10,0) + "GHC.Internal.Event.PSQ" +#else + "GHC.Event.PSQ" +#endif + +timerManagerModName :: String +timerManagerModName = +#if MIN_VERSION_ghc(9,10,0) + "GHC.Internal.Event.TimerManager" +#else + "GHC.Event.TimerManager" +#endif + +pkgName :: String +pkgName = +#if MIN_VERSION_ghc(9,10,0) + "ghc-internal" +#else + "base" +#endif + diff --git a/src/Debug/Breakpoint/TypeChecker.hs b/src/Debug/Breakpoint/TypeChecker.hs --- a/src/Debug/Breakpoint/TypeChecker.hs +++ b/src/Debug/Breakpoint/TypeChecker.hs @@ -30,21 +30,17 @@ { Ghc.tcPluginInit = initTcPlugin , Ghc.tcPluginSolve = solver , Ghc.tcPluginStop = const $ pure () -#if MIN_VERSION_ghc(9,4,0) , Ghc.tcPluginRewrite = mempty -#endif } initTcPlugin :: Ghc.TcPluginM TcPluginNames initTcPlugin = do - Ghc.Found _ breakpointMod <- + breakpointMod <- Ghc.findImportedModule' (Ghc.mkModuleName "Debug.Breakpoint") - Ghc.Found _ showMod <- - Ghc.findImportedModule' (Ghc.mkModuleName "GHC.Show") showLevClassName <- Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowLev") showLevNameTc <- Plugin.lookupOrig breakpointMod (Ghc.mkVarOcc "showLev") - showClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig showMod (Ghc.mkClsOcc "Show") + showClass <- Plugin.tcLookupClass Ghc.showClassName succeedClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "Succeed") showWrapperTyCon <- Plugin.tcLookupTyCon =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowWrapper")