Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-breakpoint for openSUSE:Factory checked in at 2023-01-18 13:09:40 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-breakpoint (Old) and /work/SRC/openSUSE:Factory/.ghc-breakpoint.new.32243 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-breakpoint" Wed Jan 18 13:09:40 2023 rev:2 rq:1059053 version:0.1.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-breakpoint/ghc-breakpoint.changes 2022-10-13 15:44:08.762972280 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-breakpoint.new.32243/ghc-breakpoint.changes 2023-01-18 13:09:48.432465673 +0100 @@ -1,0 +2,25 @@ +Fri Dec 2 23:46:01 UTC 2022 - Peter Simons <[email protected]> + +- Update breakpoint to version 0.1.2.0. + ## 0.1.2.0 -- 2022-11-18 + * `breakpoint` and `queryVars` include a `*result` binding in their output + * Fix a bug breaking Windows compatibility + * Fix a bug with overlapping breakpoints and timeouts + +------------------------------------------------------------------- +Wed Nov 2 22:09:13 UTC 2022 - Peter Simons <[email protected]> + +- Update breakpoint to version 0.1.1.1. + ## 0.1.1.1 -- 2022-11-02 + * Support `IsString` version of string literals in `excludeVars` + + ## 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 + +------------------------------------------------------------------- Old: ---- breakpoint-0.1.0.0.tar.gz New: ---- breakpoint-0.1.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-breakpoint.spec ++++++ --- /var/tmp/diff_new_pack.3kGd2p/_old 2023-01-18 13:09:49.732473139 +0100 +++ /var/tmp/diff_new_pack.3kGd2p/_new 2023-01-18 13:09:49.752473254 +0100 @@ -19,18 +19,22 @@ %global pkg_name breakpoint %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.1.0.0 +Version: 0.1.2.0 Release: 0 Summary: Set breakpoints using a GHC plugin License: MIT URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-ansi-terminal-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-ghc-devel BuildRequires: ghc-haskeline-devel BuildRequires: ghc-mtl-devel +BuildRequires: ghc-pretty-simple-devel BuildRequires: ghc-rpm-macros +BuildRequires: ghc-template-haskell-devel +BuildRequires: ghc-text-devel BuildRequires: ghc-transformers-devel ExcludeArch: %{ix86} %if %{with tests} ++++++ breakpoint-0.1.0.0.tar.gz -> breakpoint-0.1.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/CHANGELOG.md new/breakpoint-0.1.2.0/CHANGELOG.md --- old/breakpoint-0.1.0.0/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/breakpoint-0.1.2.0/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,22 @@ # Revision history for breakpoint +## 0.1.2.0 -- 2022-11-18 +* `breakpoint` and `queryVars` include a `*result` binding in their output +* Fix a bug breaking Windows compatibility +* Fix a bug with overlapping breakpoints and timeouts + +## 0.1.1.1 -- 2022-11-02 +* Support `IsString` version of string literals in `excludeVars` + +## 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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/breakpoint.cabal new/breakpoint-0.1.2.0/breakpoint.cabal --- old/breakpoint-0.1.0.0/breakpoint.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/breakpoint-0.1.2.0/breakpoint.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,6 @@ cabal-version: 3.0 name: breakpoint -version: 0.1.0.0 +version: 0.1.2.0 synopsis: Set breakpoints using a GHC plugin @@ -15,7 +15,7 @@ license-file: LICENSE author: Aaron Allen maintainer: [email protected] -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 @@ -45,7 +50,7 @@ test-suite spec main-is: Spec.hs - other-modules: ApplicativeDo + other-modules: ApplicativeDo, OverloadedStrings hs-source-dirs: test build-depends: base, tasty, tasty-hunit, breakpoint, containers type: exitcode-stdio-1.0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/src/Debug/Breakpoint/GhcFacade.hs new/breakpoint-0.1.2.0/src/Debug/Breakpoint/GhcFacade.hs --- old/breakpoint-0.1.0.0/src/Debug/Breakpoint/GhcFacade.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/breakpoint-0.1.2.0/src/Debug/Breakpoint/GhcFacade.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} @@ -12,17 +13,60 @@ , noLocA' , locA' , mkWildValBinder' + , pprTypeForUser' + , showSDocOneLine' + , findImportedModule' + , findPluginModule' , pattern HsLet' , pattern LetStmt' , pattern ExplicitList' , pattern BindStmt' + , pattern OverLit' ) 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 +102,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 +131,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 +173,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 +238,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' @@ -247,3 +353,13 @@ #else pattern BindStmt' x pat body bindExpr failExpr = Ghc.BindStmt x pat body bindExpr failExpr #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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/src/Debug/Breakpoint/TimerManager.hs new/breakpoint-0.1.2.0/src/Debug/Breakpoint/TimerManager.hs --- old/breakpoint-0.1.0.0/src/Debug/Breakpoint/TimerManager.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/breakpoint-0.1.2.0/src/Debug/Breakpoint/TimerManager.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,166 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Debug.Breakpoint.TimerManager + ( suspendTimeouts + ) where + +#if defined(mingw32_HOST_OS) || !MIN_VERSION_ghc(9,2,0) +-- Since Windows has its own timeout manager internals, I'm choosing not to support it for now. + +suspendTimeouts :: IO a -> IO a +suspendTimeouts = id + +#else + +import Control.Concurrent(rtsSupportsBoundThreads) +import Control.Monad (when) +import Data.Foldable (foldl') +import Data.IORef +import Data.Word (Word64) +import qualified GHC.Clock as Clock +import GHC.Event +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import System.IO.Unsafe + +-------------------------------------------------------------------------------- +-- 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) +-- -- 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) + +-- | 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 +suspendTimeouts action = do + alreadySuspended <- readIORef timeoutsSuspended + -- Don't allow nested breakpoints to both modify timeouts + if alreadySuspended || not rtsSupportsBoundThreads + then action + else do + writeIORef timeoutsSuspended True + 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? + writeIORef timeoutsSuspended False + pure r + +timeoutsSuspended :: IORef Bool +timeoutsSuspended = unsafePerformIO $ newIORef False +{-# NOINLINE timeoutsSuspended #-} + +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/src/Debug/Breakpoint.hs new/breakpoint-0.1.2.0/src/Debug/Breakpoint.hs --- old/breakpoint-0.1.0.0/src/Debug/Breakpoint.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/breakpoint-0.1.2.0/src/Debug/Breakpoint.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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,36 +122,75 @@ 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 = @@ -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,10 +288,11 @@ 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) - MkEnv { varSet = mempty, .. } + (group', _) <- + runReaderT (runWriterT $ recurse group) + MkEnv { varSet = mempty, .. } pure (gblEnv, 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 @@ -277,7 +337,7 @@ . Ghc.ppr $ Ghc.locA' loc - captureVarsExpr = + captureVarsExpr mResultName = let mkTuple (Ghc.fromLexicalFastString -> varStr, n) = Ghc.mkLHsTupleExpr [ Ghc.nlHsLit . Ghc.mkHsString $ Ghc.unpackFS varStr @@ -289,46 +349,65 @@ mkList exprs = Ghc.noLocA' (Ghc.ExplicitList' Ghc.NoExtField exprs) + varSetWithResult + | Just resName <- mResultName = + M.insert (Ghc.mkLexicalFastString $ Ghc.mkFastString "*result") + resName + varSet + | otherwise = varSet + in Ghc.nlHsApp (Ghc.nlHsVar fromListName) . mkList - $ mkTuple <$> M.toList varSet + $ mkTuple <$> M.toList varSetWithResult - bpExpr = - Ghc.nlHsApp - (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr) - captureVarsExpr + bpExpr = do + resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_") + pure $ + Ghc.mkHsLam [Ghc.nlVarPat resultName] $ + Ghc.nlHsApp + (Ghc.nlHsApp + (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr) + (captureVarsExpr $ Just resultName) + ) + (Ghc.nlHsVar resultName) bpMExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitMName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing bpIOExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitIOName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing queryVarsIOExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar runPromptIOName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing - queryVarsExpr = - Ghc.nlHsApp - (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr) - captureVarsExpr + queryVarsExpr = do + resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_") + pure $ + Ghc.mkHsLam [Ghc.nlVarPat resultName] $ + Ghc.nlHsApp + (Ghc.nlHsApp + (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr) + (captureVarsExpr $ Just resultName) + ) + (Ghc.nlHsVar resultName) queryVarsMExpr = Ghc.nlHsApp (Ghc.nlHsApp (Ghc.nlHsVar runPromptMName) srcLocStringExpr) - captureVarsExpr + $ captureVarsExpr Nothing if | captureVarsName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc captureVarsExpr) + pure (Just . Ghc.unLoc $ captureVarsExpr Nothing) | breakpointName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc bpExpr) + Just . Ghc.unLoc <$> lift (lift bpExpr) | breakpointMName == name -> do tell $ Any True @@ -344,7 +423,7 @@ | queryVarsName == name -> do tell $ Any True - pure (Just $ Ghc.unLoc queryVarsExpr) + Just . Ghc.unLoc <$> lift (lift queryVarsExpr) | queryVarsMName == name -> do tell $ Any True @@ -357,6 +436,36 @@ 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 (Ghc.HsOverLit _ (Ghc.OverLit' (Ghc.HsIsString _ 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 +517,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 +566,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 +587,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 +669,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 @@ -613,7 +726,7 @@ -------------------------------------------------------------------------------- -- The writer is for tracking if an inner expression contains the target name -type EnvReader = WriterT Any (Reader Env) +type EnvReader = WriterT Any (ReaderT Env Ghc.TcM) type VarSet = M.Map Ghc.LexicalFastString' Ghc.Name @@ -635,6 +748,7 @@ , runPromptName :: !Ghc.Name , runPromptMName :: !Ghc.Name , getSrcLocName :: !Ghc.Name + , excludeVarsName :: !Ghc.Name } overVarSet :: (VarSet -> VarSet) -> Env -> Env @@ -685,14 +799,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 +853,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 +876,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 +910,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 +940,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 @@ -837,6 +959,11 @@ 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 showLev f = show $ Exts.F# f diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/test/OverloadedStrings.hs new/breakpoint-0.1.2.0/test/OverloadedStrings.hs --- old/breakpoint-0.1.0.0/test/OverloadedStrings.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/breakpoint-0.1.2.0/test/OverloadedStrings.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module OverloadedStrings + ( testTree + ) where + +import qualified Data.Map as M +import Test.Tasty +import Test.Tasty.HUnit + +import Debug.Breakpoint + +-- Needs to be a separate module b/c ApplicativeDo affects other tests + +testTree :: TestTree +testTree = testGroup "IsString" + [ testCase "exclude vars" excludeVarsTest + ] + +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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/breakpoint-0.1.0.0/test/Spec.hs new/breakpoint-0.1.2.0/test/Spec.hs --- old/breakpoint-0.1.0.0/test/Spec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/breakpoint-0.1.2.0/test/Spec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 @@ -8,6 +11,7 @@ import Debug.Breakpoint import qualified ApplicativeDo as ApDo +import qualified OverloadedStrings as OS main :: IO () main = defaultMain testTree @@ -34,7 +38,12 @@ , 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 + , OS.testTree ] -- TODO -- Implicit Params @@ -75,7 +84,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 +133,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 +160,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 +184,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 +206,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
