breakpoint 0.1.3.1 → 0.1.4.0

raw patch · 7 files changed

+88/−165 lines, 7 filesdep ~basedep ~containersdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, containers, ghc, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• breakpoint.cabal +8/−7
• src/Debug/Breakpoint/GhcFacade.hs +27/−93
• src/Debug/Breakpoint/Renamer.hs +5/−5
• src/Debug/Breakpoint/TimerManager.hs +11/−54
• src/Debug/Breakpoint/TimerManager/Names.hs +31/−0
• src/Debug/Breakpoint/TypeChecker.hs +2/−6

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+

@@ -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")