breakpoint 0.1.0.0 → 0.1.1.0

raw patch · 6 files changed

+494/−67 lines, 6 filesdep +ansi-terminaldep +pretty-simpledep +template-haskelldep ~basedep ~haskelinePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ansi-terminal, pretty-simple, template-haskell, text

Dependency ranges changed: base, haskeline

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• breakpoint.cabal +10/−5
• src/Debug/Breakpoint.hs +155/−51
• src/Debug/Breakpoint/GhcFacade.hs +111/−6
• src/Debug/Breakpoint/TimerManager.hs +153/−0
• test/Spec.hs +56/−5

@@ -1,5 +1,14 @@ # Revision history for breakpoint +## 0.1.1.0 -- 2022-10-30++* Support for GHC 9.4.*+* Values are pretty printed using `pretty-simple`+* Timeouts are suspended during breakpoints for GHC >= 9.2 and non-windows+* Fix a bug with monadic binds in do blocks+* Variable names are no longer visible in their definition body+* Adds `excludeVars` to ingore a list of vars, especially those that don't compile+ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               breakpoint-version:            0.1.0.0+version:            0.1.1.0 synopsis:   Set breakpoints using a GHC plugin @@ -15,7 +15,7 @@ license-file:       LICENSE author:             Aaron Allen maintainer:         aaronallen8455@gmail.com-tested-with: GHC==9.2.2, GHC==9.0.2, GHC==8.10.7+tested-with: GHC==9.4.2, GHC==9.2.2, GHC==9.0.2, GHC==8.10.7 bug-reports: https://github.com/aaronallen8455/breakpoint/issues  -- A copyright notice.@@ -25,19 +25,24 @@  library     exposed-modules:  Debug.Breakpoint,-                      Debug.Breakpoint.GhcFacade+                      Debug.Breakpoint.GhcFacade,+                      Debug.Breakpoint.TimerManager,      -- Modules included in this library but not exported.     -- other-modules:      -- LANGUAGE extensions used by modules in this package.     -- other-extensions:-    build-depends:    base >=4.14.0.0 && <4.17.0.0,+    build-depends:    base >=4.14.0.0 && <4.18.0.0,                       ghc,                       containers,                       mtl,                       transformers,-                      haskeline+                      haskeline >= 0.8.2,+                      pretty-simple,+                      text,+                      template-haskell,+                      ansi-terminal     hs-source-dirs:   src     default-language: Haskell2010     ghc-options: -Wall

@@ -1,4 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-}@@ -14,8 +13,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-} module Debug.Breakpoint-  ( plugin+  ( -- * Plugin+    plugin+    -- * API+  , breakpoint+  , breakpointM+  , breakpointIO+  , queryVars+  , queryVarsM+  , queryVarsIO+  , excludeVars+    -- * Internals   , captureVars   , showLev   , fromAscList@@ -25,12 +35,6 @@   , runPrompt   , runPromptM   , runPromptIO-  , breakpoint-  , queryVars-  , breakpointM-  , queryVarsM-  , breakpointIO-  , queryVarsIO   , getSrcLoc   ) where @@ -50,6 +54,7 @@ import qualified Data.Map.Lazy as M import           Data.Maybe import           Data.Monoid (Any(..))+import qualified Data.Text.Lazy as T import           Data.Traversable (for) import           Debug.Trace (trace, traceIO, traceM) import qualified GHC.Exts as Exts@@ -60,19 +65,25 @@ import qualified TcPluginM as Plugin #endif import           GHC.Word+import qualified System.Console.ANSI as ANSI import qualified System.Console.Haskeline as HL+import           System.Environment (lookupEnv)+import           System.IO (stdout) import           System.IO.Unsafe (unsafePerformIO)+import qualified Text.Pretty.Simple as PS+import qualified Text.Pretty.Simple.Internal.Color as PS  import qualified Debug.Breakpoint.GhcFacade as Ghc+import qualified Debug.Breakpoint.TimerManager as TM  -------------------------------------------------------------------------------- -- API --------------------------------------------------------------------------------  -- | Constructs a lazy 'Map' from the names of all visible variables at the call--- site to a string representation of their value. Be careful about binding this--- to a variable because that variable will also be captured, resulting in an--- infinite loop if that element of the Map is evaluated.+-- site to a string representation of their value. Does not include any variables+-- whose definitions contain it. Be careful not to assign multiple variables to+-- `captureVars` in the same scope as this will result in an infinite recursion. captureVars :: M.Map String String captureVars = mempty @@ -90,14 +101,18 @@  printAndWaitIO :: MonadIO m => String -> M.Map String String -> m () printAndWaitIO srcLoc vars = liftIO $ do-  traceIO $ L.intercalate "\n"-    [ color "31" "### Breakpoint Hit ###"-    , color "37" "(" <> srcLoc <> ")"-    , printVars vars-    , color "32" "Press enter to continue"-    ]-  _ <- blockOnInput-  pure ()+  useColor <- ANSI.hSupportsANSIColor stdout+  let ?useColor = useColor+  prettyPrint <- usePrettyPrinting+  let ?prettyPrint = prettyPrint+  TM.suspendTimeouts $ do+    traceIO $ L.intercalate "\n"+      [ color red "### Breakpoint Hit ###"+      , color grey "(" <> srcLoc <> ")"+      , printVars vars+      , color green "Press enter to continue"+      ]+    void blockOnInput  runPrompt :: String -> M.Map String String -> a -> a runPrompt srcLoc vars x =@@ -107,37 +122,76 @@ runPromptM :: Applicative m => String -> M.Map String String -> m () runPromptM srcLoc vars = runPrompt srcLoc vars $ pure () -runPromptIO :: MonadIO m => String -> M.Map String String -> m ()+runPromptIO :: forall m. MonadIO m => String -> M.Map String String -> m () runPromptIO srcLoc vars = liftIO . HL.runInputTBehavior HL.defaultBehavior settings $ do+    useColor <- liftIO $ ANSI.hSupportsANSIColor stdout+    let ?useColor = useColor+    prettyPrint <- liftIO usePrettyPrinting+    let ?prettyPrint = prettyPrint+    let printVar var val =+          HL.outputStrLn $ color cyan (var ++ " =\n") ++ prettify val+        inputLoop = do+          mInp <- HL.getInputLine $ color green "Enter variable name: "+          case mInp of+            Just (L.dropWhileEnd isSpace . dropWhile isSpace -> inp)+              | not (null inp) -> do+                  traverse_ (printVar inp) $ M.lookup inp vars+                  inputLoop+            _ -> pure ()     HL.outputStrLn . unlines $-      [ color "31" "### Breakpoint Hit ###"-      , color "37" $ "(" <> srcLoc <> ")"-      ] ++ (color "36" <$> varNames)+      [ color red "### Breakpoint Hit ###"+      , color grey $ "(" <> srcLoc <> ")"+      ] ++ (color cyan <$> varNames)     inputLoop   where-    varNames = M.keys vars     settings = HL.setComplete completion HL.defaultSettings     completion = HL.completeWord' Nothing isSpace $ \str ->       pure $ HL.simpleCompletion         <$> filter (str `L.isPrefixOf`) varNames-    printVar var val = HL.outputStrLn $ color "36" (var ++ " = ") ++ val-    inputLoop = do-      mInp <- HL.getInputLine $ color "32" "Enter variable name: "-      case mInp of-        Just (L.dropWhileEnd isSpace . dropWhile isSpace -> inp)-          | not (null inp) -> do-              traverse_ (printVar inp) $ M.lookup inp vars-              inputLoop-        _ -> pure ()+    varNames = M.keys vars -color :: String -> String -> String-color c s = "\ESC[" <> c <> "m\STX" <> s <> "\ESC[m\STX"+usePrettyPrinting :: IO Bool+usePrettyPrinting = isNothing <$> lookupEnv "NO_PRETTY_PRINT" -printVars :: M.Map String String -> String+color :: (?useColor :: Bool) => String -> String -> String+color c s =+  if ?useColor+     then "\ESC[" <> c <> "m\STX" <> s <> "\ESC[m\STX"+     else s++red, green, grey, cyan :: String+red = "31"+green = "32"+grey = "37"+cyan = "36"++printVars :: (?useColor :: Bool, ?prettyPrint :: Bool)+          => M.Map String String -> String printVars vars =-  let mkLine (k, v) = color "36" (k <> " = ") <> v-   in unlines $ mkLine <$> M.toList vars+  let eqSign | ?prettyPrint = " =\n"+             | otherwise = " = "+      mkLine (k, v) = color cyan (k <> eqSign) <> prettify v+   in unlines . L.intersperse "" $ mkLine <$> M.toList vars +-- TODO don't apply parsing to things inside angle brackets+prettify :: (?prettyPrint :: Bool) => String -> String+prettify =+  if ?prettyPrint+  then T.unpack+     . PS.pStringOpt+         PS.defaultOutputOptionsDarkBg+           { PS.outputOptionsInitialIndent = 2+           , PS.outputOptionsIndentAmount = 2+           , PS.outputOptionsColorOptions = Just PS.ColorOptions+             { PS.colorQuote = PS.colorNull+             , PS.colorString = PS.colorBold PS.Vivid PS.Blue+             , PS.colorError = PS.colorBold PS.Vivid PS.Red+             , PS.colorNum = PS.colorBold PS.Vivid PS.Green+             , PS.colorRainbowParens = [PS.colorBold PS.Vivid PS.Cyan]+             }+           }+  else id+ inactivePluginStr :: String inactivePluginStr =   "Cannot set breakpoint: the Debug.Trace plugin is not active"@@ -194,6 +248,11 @@ blockOnInput = 1 <$ getLine #endif +-- | Excludes the given variable names from appearing in the output of any+-- breakpoints occurring in the given expression.+excludeVars :: [String] -> a -> a+excludeVars _ = id+ -------------------------------------------------------------------------------- -- Plugin --------------------------------------------------------------------------------@@ -210,9 +269,8 @@   -> Ghc.HsGroup Ghc.GhcRn   -> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn) renameAction gblEnv group = do-  hscEnv <- Ghc.getTopEnv-  Ghc.Found _ breakpointMod <- liftIO $-    Ghc.findPluginModule hscEnv (Ghc.mkModuleName "Debug.Breakpoint")+  Ghc.Found _ breakpointMod <-+    Ghc.findPluginModule' (Ghc.mkModuleName "Debug.Breakpoint")    captureVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "captureVars")   showLevName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "showLev")@@ -230,6 +288,7 @@   runPromptMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPromptM")   runPromptName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPrompt")   getSrcLocName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "getSrcLoc")+  excludeVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "excludeVars")    let (group', _) =         runReader (runWriterT $ recurse group)@@ -247,6 +306,7 @@ transform :: forall a. Data a => a -> EnvReader (Maybe a) transform a = runMaybeT       $ wrap hsVarCase+    <|> wrap hsAppCase     <|> wrap matchCase     <|> wrap grhssCase     <|> wrap hsLetCase@@ -357,6 +417,32 @@ hsVarCase _ = pure Nothing  --------------------------------------------------------------------------------+-- App Expr+--------------------------------------------------------------------------------++hsAppCase :: Ghc.LHsExpr Ghc.GhcRn+          -> 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 f+  = do+    MkEnv{..} <- lift ask+    if excludeVarsName /= name+       then pure Nothing+       else do+         let extractVarName (Ghc.HsLit _ (Ghc.HsString _ fs)) =+               Just $ Ghc.mkLexicalFastString fs+             extractVarName _ = Nothing+             varsToExclude =+               mapMaybe (extractVarName . Ghc.unLoc) exprsToExclude+         Just <$>+           mapWriterT+            (local (overVarSet $ \vs -> foldr M.delete vs varsToExclude))+            (recurse innerExpr)+hsAppCase _ = pure Nothing++-------------------------------------------------------------------------------- -- Match -------------------------------------------------------------------------------- @@ -408,16 +494,18 @@              -> EnvReader (Ghc.LHsBind Ghc.GhcRn) dealWithBind resultNames lbind = for lbind $ \case   Ghc.FunBind {..} -> do+    let resultNamesSansSelf =+          M.delete (getOccNameFS $ Ghc.unLoc fun_id) resultNames     (matchesRes, Any containsTarget)       <- listen-       . addScopedVars resultNames+       . addScopedVars resultNamesSansSelf        $ recurse fun_matches     -- be sure to use the result names on the right so that they are overriden     -- by any shadowing vars inside the expr.     let rhsVars           | containsTarget           = Ghc.mkUniqSet . M.elems-            . (<> resultNames) . mkVarSet+            . (<> resultNamesSansSelf) . mkVarSet             $ Ghc.nonDetEltsUniqSet fun_ext           | otherwise = fun_ext     pure Ghc.FunBind { Ghc.fun_matches = matchesRes, Ghc.fun_ext = rhsVars, .. }@@ -455,7 +543,9 @@           | otherwise = psb_ext     pure $ Ghc.PatSynBind x Ghc.PSB { psb_def = defRes, psb_ext = rhsVars, .. } +#if !MIN_VERSION_ghc(9,4,0)   other -> pure other+#endif  grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)          -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))@@ -474,12 +564,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 (Ghc.L loc localBinds) inExpr) = do+hsLetCase (Ghc.HsLet' x letToken (Ghc.L loc localBinds) inToken inExpr) = do   (bindsRes, names) <- dealWithLocalBinds localBinds    inExprRes <- addScopedVars names $ recurse inExpr   pure . Just $-    Ghc.HsLet' x (Ghc.L loc bindsRes) inExprRes+    Ghc.HsLet' x letToken (Ghc.L loc bindsRes) inToken inExprRes hsLetCase _ = pure Nothing  dealWithLocalBinds@@ -556,7 +646,7 @@   Ghc.BindStmt' x lpat body bindExpr failExpr -> do     let names = extractVarPats lpat     tell names-    bodyRes <- lift . addScopedVars names $ recurse body+    bodyRes <- lift $ recurse body     pure $ Ghc.BindStmt' x lpat bodyRes bindExpr failExpr    Ghc.LetStmt' x (Ghc.L loc localBinds) -> do@@ -635,6 +725,7 @@   , runPromptName :: !Ghc.Name   , runPromptMName :: !Ghc.Name   , getSrcLocName :: !Ghc.Name+  , excludeVarsName :: !Ghc.Name   }  overVarSet :: (VarSet -> VarSet) -> Env -> Env@@ -685,14 +776,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 <--    Plugin.findImportedModule (Ghc.mkModuleName "Debug.Breakpoint") Nothing+    Ghc.findImportedModule' (Ghc.mkModuleName "Debug.Breakpoint")   Ghc.Found _ showMod <--    Plugin.findImportedModule (Ghc.mkModuleName "GHC.Show") (Just $ Ghc.fsLit "base")+    Ghc.findImportedModule' (Ghc.mkModuleName "GHC.Show")    showLevClassName <- Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowLev")   showClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig showMod (Ghc.mkClsOcc "Show")@@ -736,7 +830,7 @@   -> Ghc.TcPluginM (Maybe Ghc.EvTerm) buildDict names cls tys = do   instEnvs <- Plugin.getInstEnvs-  case Ghc.lookupUniqueInstEnv instEnvs (showClass names) tys of+  case Ghc.lookupUniqueInstEnv instEnvs cls tys of     Right (clsInst, _) -> do       let dfun = Ghc.is_dfun clsInst           (vars, subclasses, inst) = Ghc.tcSplitSigmaTy $ Ghc.idType dfun@@ -759,7 +853,7 @@           let (inst, _) = fromRight (error "impossible: no Show instance for ShowWrapper") $                 Ghc.lookupUniqueInstEnv                   instEnvs-                  cls+                  (showClass names)                   [Ghc.mkTyConApp (showWrapperTyCon names) [ty]]               liftedDict =                 liftDict inst ty (getEvExprFromDict unshowableDict)@@ -793,7 +887,7 @@  buildUnshowableDict :: Ghc.Type -> Ghc.TcM Ghc.EvTerm buildUnshowableDict ty = do-  let tyString = Ghc.showSDocUnsafe $ Ghc.pprTypeForUser ty+  let tyString = Ghc.showSDocOneLine' $ Ghc.pprTypeForUser' ty   str <- Ghc.mkStringExpr $ "<" <> tyString <> ">"   pure . Ghc.EvExpr $     Ghc.mkCoreLams [Ghc.mkWildValBinder' ty] str@@ -823,6 +917,11 @@   showLev i = show $ I32# i #endif +#if MIN_VERSION_base(4,17,0)+instance ShowLev 'Exts.Int64Rep Exts.Int64# where+  showLev i = show $ I64# i+#endif+ instance ShowLev 'Exts.WordRep Exts.Word# where   showLev w = show $ W# w @@ -835,6 +934,11 @@  instance ShowLev 'Exts.Word32Rep Exts.Word32# where   showLev w = show $ W32# w+#endif++#if MIN_VERSION_base(4,17,0)+instance ShowLev 'Exts.Word64Rep Exts.Word64# where+  showLev w = show $ W64# w #endif  instance ShowLev 'Exts.FloatRep Exts.Float# where

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-}@@ -12,17 +13,59 @@   , noLocA'   , locA'   , mkWildValBinder'+  , pprTypeForUser'+  , showSDocOneLine'+  , findImportedModule'+  , findPluginModule'   , pattern HsLet'   , pattern LetStmt'   , pattern ExplicitList'   , pattern BindStmt'   ) where -#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,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 hiding (DefaultingPlugin)+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, DefaultingPlugin)+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.Rename.Bind 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.Types.PkgQual 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@@ -58,6 +101,7 @@ import           GHC.Driver.Finder as Ghc import           GHC.Hs.Extension 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@@ -86,14 +130,17 @@ import           GHC.Core.TyCon as Ghc import           GHC.Core.Ppr.TyThing as Ghc import           GHC.Driver.Types as Ghc+import           GHC.Driver.Session as Ghc import           GHC.Hs.Expr as Ghc import           GHC.Hs.Pat as Ghc import           GHC.Hs.Decls as Ghc+import           GHC.Hs.Lit as Ghc  #elif MIN_VERSION_ghc(8,10,0) import           GHC.Hs.Expr as Ghc import           GHC.Hs.Extension as Ghc import           GHC.Hs.Binds as Ghc+import           GHC.Hs.Lit as Ghc import           SrcLoc as Ghc import           GHC.Hs.Utils as Ghc import           Name as Ghc@@ -125,6 +172,8 @@ import           GHC.Hs.Decls as Ghc import           TcRnMonad as Ghc import           Plugins as Ghc hiding (TcPlugin)+import           DynFlags as Ghc+import qualified TcPluginM as Plugin #endif  liftedRepName :: Ghc.Name@@ -188,18 +237,74 @@ mkWildValBinder' = Ghc.mkWildValBinder #endif +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' =+#if MIN_VERSION_ghc(9,2,0)+  Ghc.showSDocOneLine Ghc.defaultSDocContext+#elif MIN_VERSION_ghc(9,0,0)+  Ghc.showSDocOneLine+    $ Ghc.initDefaultSDocContext Ghc.unsafeGlobalDynFlags+#else+  Ghc.showSDocOneLine Ghc.unsafeGlobalDynFlags+#endif++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++findPluginModule' :: Ghc.ModuleName -> Ghc.TcM Ghc.FindResult+#if MIN_VERSION_ghc(9,4,0)+findPluginModule' modName =+  Ghc.runTcPluginM $ Plugin.findImportedModule modName Ghc.NoPkgQual+#else+findPluginModule' modName = do+  hscEnv <- Ghc.getTopEnv+  liftIO $ Ghc.findPluginModule hscEnv modName+#endif++#if MIN_VERSION_ghc(9,4,0)+type LetToken =+  Ghc.LHsToken "let" Ghc.GhcRn+type InToken =+  Ghc.LHsToken "in" Ghc.GhcRn+#else+type LetToken = ()+type InToken = ()+#endif+ pattern HsLet'   :: Ghc.XLet Ghc.GhcRn+  -> LetToken   -> Ghc.Located (Ghc.HsLocalBinds Ghc.GhcRn)+  -> InToken   -> Ghc.LHsExpr Ghc.GhcRn   -> Ghc.HsExpr Ghc.GhcRn-#if MIN_VERSION_ghc(9,2,0)-pattern HsLet' x lbinds expr <--  Ghc.HsLet x (Ghc.L Ghc.noSrcSpan -> lbinds) expr+#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 (Ghc.L _ binds) expr = Ghc.HsLet x binds expr+    HsLet' x letToken (Ghc.L _ binds) inToken expr =+      Ghc.HsLet x letToken binds inToken expr+#elif MIN_VERSION_ghc(9,2,0)+pattern HsLet' x letToken lbinds inToken expr <-+  Ghc.HsLet (pure . pure -> (letToken, (inToken, x))) (Ghc.L Ghc.noSrcSpan -> lbinds) expr+  where+    HsLet' x () (Ghc.L _ binds) () expr = Ghc.HsLet x binds expr #else-pattern HsLet' x lbinds expr = Ghc.HsLet x lbinds expr+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'

@@ -0,0 +1,153 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module Debug.Breakpoint.TimerManager+  ( modifyTimeouts+  , suspendTimeouts+  ) where++import           Control.Concurrent(rtsSupportsBoundThreads)+import           Control.Monad (when)+import           Data.Foldable (foldl')+import           Data.IORef (atomicModifyIORef')+import           Data.Word (Word64)+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Clock as Clock+#endif+import           GHC.Event+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++--------------------------------------------------------------------------------+-- Hidden functions imported via TH+--------------------------------------------------------------------------------++psqToList =+  $(pure $ VarE $+      Name (OccName "toList")+           (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))+   )++psqAdjust =+  $(pure $ VarE $+      Name (OccName "adjust")+           (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))+   )++psqKey =+  $(pure $ VarE $+      Name (OccName "key")+           (NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))+   )++-- emTimeouts :: TimerManager -> IORef TimeoutQueue+emTimeouts =+  $(pure $ VarE $+      Name (OccName "emTimeouts")+           (NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager"))+   )++wakeManager :: TimerManager -> IO ()+wakeManager =+  $(pure $ VarE $+      Name (OccName "wakeManager")+           (NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager"))+   )++-- 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+--------------------------------------------------------------------------------++-- editTimeouts :: TimerManager -> TimeoutEdit -> IO ()+editTimeouts mgr g = do+  atomicModifyIORef' (emTimeouts mgr) f+  wakeManager mgr+  where+    f q = (g q, ())++-- | Modify the times in nanoseconds at which all currently registered timeouts+-- will expire.+modifyTimeouts :: (Word64 -> Word64) -> IO ()+modifyTimeouts f =+  -- This only works for the threaded RTS+  when rtsSupportsBoundThreads $ do+#if defined(mingw32_HOST_OS)+    pure ()+    -- 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+          upd pq' k =+            psqAdjust f k pq'+       in foldl' upd pq (psqKey <$> els)+#endif++-- | has the effect of suspending timeouts while an action is occurring. This+-- is only used for GHC >= 9.2 because the semantics are too strange without+-- the ability to freeze the runtime.+suspendTimeouts :: IO a -> IO a+#if MIN_VERSION_ghc(9,2,0)+suspendTimeouts action = do+  let oneYear = 1000 * 1000000 * 60 * 60 * 24 * 365+  -- Add a large length of time to all timeouts so that they don't immediately+  -- expire when blocking ends+  modifyTimeouts (+ oneYear)+  before <- Clock.getMonotonicTimeNSec+  r <- action+  after <- Clock.getMonotonicTimeNSec+  let elapsed = after - before+  -- Set timeouts back to where they were plus the length of time spent blocking+  modifyTimeouts (subtract $ oneYear - elapsed)+  -- NB: any timeouts registered right before the block or immediately afterwards+  -- would result in strange behavior. Perhaps do an atomic modify of the IORef+  -- holding the timeout queue that covers the whole transaction?+  pure r+#else+suspendTimeouts = id+#endif

@@ -1,6 +1,9 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Arrows #-} import           Control.Arrow+import           Control.Monad+import           Data.Fixed import qualified Data.Map as M import           Data.Maybe import           Test.Tasty@@ -34,6 +37,10 @@     , testCase "arrow notation" arrowNotation     , testCase "record field bindings" recFieldBindings     , testCase "record wild cards" recWildCards+    , testCase "do block in where bind" doBlockInWhereBind+    , testCase "don't capture do bind in its body" captureInBodyOfDoBind+    , testCase "Shows type that subclass for Show" showFixedPointNumber+    , testCase "exclude vars" excludeVarsTest     , ApDo.testTree     ]     -- TODO@@ -75,7 +82,7 @@    in captureVars  nestedInLet :: Assertion-nestedInLet = M.delete "x" (test5 1) @?= M.fromList [("a", "1"), ("b", "2"), ("c", "3")]+nestedInLet = test5 1 @?= M.fromList [("a", "1"), ("b", "2"), ("c", "3")]  test5 :: Int -> M.Map String String test5 a =@@ -124,7 +131,7 @@ test10 = \a -> captureVars  letScoping :: Assertion-letScoping = M.delete "a" test11 @?= M.fromList [("b", "True"), ("c", "False")]+letScoping = test11 @?= M.fromList [("b", "True"), ("c", "False")]  test11 :: M.Map String String test11 =@@ -151,7 +158,7 @@   pure captureVars  monadicBindsScoped :: Assertion-monadicBindsScoped = M.delete "m" test14 @?= M.fromList [("a", "True")]+monadicBindsScoped = test14 @?= M.fromList [("a", "True")]  test14 :: M.Map String String test14 = fromMaybe mempty $ do@@ -175,8 +182,7 @@ test16 = head [ captureVars | let b = False, a <- [True] ]  arrowNotation :: Assertion-arrowNotation = M.delete "go" test17 @?= M.fromList [("a", "2"), ("b", "0"), ("x", "1")]--- "go" has different printed type sigs for 9.0 vs 8.10+arrowNotation = test17 @?= M.fromList [("a", "2"), ("b", "0"), ("x", "1")]  test17 :: M.Map String String test17 = go (1 :: Int) where@@ -198,3 +204,48 @@ test19 :: Rec -> M.Map String String test19 MkRec{..} = captureVars +doBlockInWhereBind :: Assertion+doBlockInWhereBind = do+  r <- test20+  M.delete "whereDo" r @?= M.fromList [("x", "True")]++test20 :: forall m. Monad m => m (M.Map String String)+test20 = do+  x <- whereDo True+  pure captureVars+  where+    whereDo :: Bool -> m Bool+    whereDo y = do+      pure y++captureInBodyOfDoBind :: Assertion+captureInBodyOfDoBind = do+  r <- test21+  M.delete "wb" r @?= M.fromList [("y", "True")]++test21 :: IO (M.Map String String)+test21 = do+  x <- wb $ \y -> do+    pure captureVars+  pure x+  where+    wb k = k True++showFixedPointNumber :: Assertion+showFixedPointNumber = do+  let m = test22+  m @?= M.fromList [("x", "4.000000")]++test22 :: M.Map String String+test22 = let x = (4 :: Micro) in captureVars++excludeVarsTest :: Assertion+excludeVarsTest = do+  let m = test23+  m @?= M.fromList [("x", "True")]++test23 :: M.Map String String+test23 =+  let x = True+      y = False+   in excludeVars ["y"] captureVars