graph-trace (empty) → 0.1.0.0
raw patch · 10 files changed
+1431/−0 lines, 10 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, ghc, ghc-boot, ghc-prim, random, syb, template-haskell, transformers
Files
- CHANGELOG.md +5/−0
- graph-trace.cabal +52/−0
- src/Graph/Trace.hs +119/−0
- src/Graph/Trace/Internal/GhcFacade.hs +238/−0
- src/Graph/Trace/Internal/Instrument.hs +433/−0
- src/Graph/Trace/Internal/Predicates.hs +135/−0
- src/Graph/Trace/Internal/RuntimeRep.hs +121/−0
- src/Graph/Trace/Internal/Solver.hs +46/−0
- src/Graph/Trace/Internal/Trace.hs +127/−0
- src/Graph/Trace/Internal/Types.hs +155/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for graph-trace++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ graph-trace.cabal view
@@ -0,0 +1,52 @@+cabal-version: 2.4+name: graph-trace+version: 0.1.0.0++synopsis:+ Trace the call graph of a program++description:+ A plugin that instruments a program so that running it produces a log which+ can be processed into a visual graph using @graph-trace-viz@.+ .+ See the [README](https://github.com/aaronallen8455/graph-trace#graph-trace) for details.++-- A URL where users can report bugs.+bug-reports: https://github.com/aaronallen8455/graph-trace/issues++-- The license under which the package is released.+license: MIT++-- The package author(s).+-- author:+maintainer: aaronallen8455@gmail.com++-- A copyright notice.+copyright: Copyright (C) 2022 Aaron Allen+category: tooling, debug, development, graph, plugin+extra-source-files: CHANGELOG.md+tested-with: GHC==9.2.1, GHC==9.0.1, GHC==8.10.7++library+ default-language: Haskell2010+ exposed-modules:+ Graph.Trace+ Graph.Trace.Internal.GhcFacade+ Graph.Trace.Internal.Types+ Graph.Trace.Internal.Trace+ Graph.Trace.Internal.Solver+ Graph.Trace.Internal.Instrument+ Graph.Trace.Internal.Predicates+ Graph.Trace.Internal.RuntimeRep+ build-depends: base >= 4.9 && < 5+ , ghc >= 8.0.0 && < 9.4.0+ , ghc-prim+ , ghc-boot+ , containers+ , syb+ , template-haskell+ , transformers+ , random+ , bytestring+ hs-source-dirs: src+ ghc-options: -Wall -Wno-unticked-promoted-constructors
+ src/Graph/Trace.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE RecordWildCards #-}+module Graph.Trace+ ( plugin+ , module DT+ , module Trace+ ) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.CPS+import qualified Data.Generics as Syb+import qualified Data.Set as S++import Graph.Trace.Internal.Predicates (addConstraintToSig, removeConstraints)+import qualified Graph.Trace.Internal.GhcFacade as Ghc+import Graph.Trace.Internal.Instrument (modifyClsInstDecl, modifyTyClDecl, modifyValBinds)+import Graph.Trace.Internal.Solver (tcPlugin)+import Graph.Trace.Internal.Types as DT+import Graph.Trace.Internal.Trace as Trace++plugin :: Ghc.Plugin+plugin =+ Ghc.defaultPlugin+ { Ghc.pluginRecompile = Ghc.purePlugin+ , Ghc.tcPlugin = \_ -> Just tcPlugin+ , Ghc.renamedResultAction = renamedResultAction+ }++findImportedModule :: String -> Ghc.TcM Ghc.Module+findImportedModule moduleName = do+ hscEnv <- Ghc.getTopEnv+ result <- liftIO $+ Ghc.findImportedModule hscEnv (Ghc.mkModuleName moduleName) Nothing+ case result of+ Ghc.Found _ m -> pure m+ _ -> error $ "unable to find module: " <> moduleName++warnAboutOptimizations :: Ghc.TcM ()+warnAboutOptimizations = do+ generalFlags <- Ghc.generalFlags <$> Ghc.getDynFlags+ when (Ghc.enumSetMember Ghc.Opt_FullLaziness generalFlags) .+ liftIO $ putStrLn " * Full laziness is enabled: it's generally recommended to disable this optimization when using graph-trace. Use the -fno-full-laziness GHC option to disable it."+ when (Ghc.enumSetMember Ghc.Opt_CSE generalFlags) .+ liftIO $ putStrLn " * Common sub-expression elimination is enabled: it's generally recommended to disable this optimization when using graph-trace. Use the -fno-cse GHC option to disable it."++isMonomorphismRestrictionOn :: Ghc.TcM Bool+isMonomorphismRestrictionOn =+ Ghc.xopt Ghc.MonomorphismRestriction <$> Ghc.getDynFlags++renamedResultAction+ :: [Ghc.CommandLineOption]+ -> Ghc.TcGblEnv+ -> Ghc.HsGroup Ghc.GhcRn+ -> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn)+renamedResultAction cmdLineOptions tcGblEnv+ hsGroup@Ghc.HsGroup{Ghc.hs_valds = Ghc.XValBindsLR{}}+ = do+ warnAboutOptimizations++ debugTypesModule <- findImportedModule "Graph.Trace.Internal.Types"+ debugTraceModule <- findImportedModule "Graph.Trace.Internal.Trace"++ traceMutePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceMute")+ traceDeepPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeep")+ traceDeepKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeepKey")+ tracePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "Trace")+ traceKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceKey")+ traceInertPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceInert")+ entryName <- Ghc.lookupOrig debugTraceModule (Ghc.mkVarOcc "entry")+ debugContextName <- Ghc.lookupOrig debugTypesModule (Ghc.mkTcOcc "DebugContext")++ let debugNames = DebugNames{..}++ -- If the "trace-all" option is passed, add the Debug predicate to all+ -- function signatures.+ let traceAllFlag = "trace-all" `elem` cmdLineOptions+ (hsGroup'@Ghc.HsGroup+ { Ghc.hs_valds = valBinds --Ghc.XValBindsLR (Ghc.NValBinds binds sigs)+ , Ghc.hs_tyclds = tyClGroups+ }, nameMap) = runWriter+ $ Syb.mkM (addConstraintToSig debugNames traceAllFlag)+ `Syb.everywhereM` hsGroup++ -- process value bindings+ (valBinds', patBindNames) <- (`evalStateT` S.empty) . runWriterT $+ Syb.mkM (modifyValBinds debugNames nameMap)+ `Syb.everywhereM`+ valBinds++ -- process type class decls and instances+ -- TODO Only need to traverse with modifyValBinds. Others are not applied deeply+ (tyClGroups', tyClPatBindNames) <- (`evalStateT` S.empty) . runWriterT $+ Syb.mkM (modifyClsInstDecl debugNames nameMap)+ `Syb.extM`+ modifyTyClDecl debugNames nameMap+ `Syb.extM`+ modifyValBinds debugNames nameMap+ `Syb.everywhereM`+ tyClGroups++ mmrOn <- isMonomorphismRestrictionOn++ -- remove predicates from signatures for pattern bound ids if monomorphism+ -- restriction is on, otherwise compilation will fail.+ let (valBinds'', tyClGroups'') =+ if mmrOn+ then ( removeConstraints debugNames patBindNames valBinds'+ , removeConstraints debugNames tyClPatBindNames tyClGroups'+ )+ else (valBinds', tyClGroups')++ pure ( tcGblEnv+ , hsGroup' { Ghc.hs_valds = valBinds''+ , Ghc.hs_tyclds = tyClGroups''+ }+ )++renamedResultAction _ tcGblEnv group = pure (tcGblEnv, group)
+ src/Graph/Trace/Internal/GhcFacade.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+module Graph.Trace.Internal.GhcFacade+ ( module Ghc+ , enumSetMember+ , pattern FunBind'+ , fun_ext'+ , fun_id'+ , fun_matches'+ , pattern HsSig'+ , setSigBody+ , noLocA'+ , emptyEpAnn+ , noLoc'+ , emptyComments'+ , pattern HsQualTy'+ , pattern RealSrcLoc'+ , pattern L'+ ) where++#if MIN_VERSION_ghc(9,2,0)+import GHC.Builtin.Names as Ghc+import GHC.Builtin.Types as Ghc+import GHC.Core.Class as Ghc+import GHC.Core.Make as Ghc+import GHC.Core.Type as Ghc+import GHC.Data.Bag as Ghc+import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.FastString as Ghc+import GHC.Driver.Plugins as Ghc hiding (TcPlugin)+import GHC.Driver.Session as Ghc+import GHC.Hs as Ghc hiding (FunDep)+import GHC.Iface.Env as Ghc+import GHC.LanguageExtensions as Ghc hiding (UnicodeSyntax)+import GHC.Rename.Expr as Ghc+import GHC.Tc.Types as Ghc+import GHC.Tc.Types.Constraint as Ghc+import GHC.Tc.Types.Evidence as Ghc+import GHC.Tc.Types.Origin as Ghc+import GHC.Tc.Utils.Monad as Ghc+import GHC.ThToHs as Ghc+import GHC.Types.Basic as Ghc+import GHC.Types.Fixity as Ghc+import GHC.Types.Name as Ghc hiding (varName)+import GHC.Types.SrcLoc as Ghc+import GHC.Types.Unique.Supply as Ghc+import GHC.Unit.Finder as Ghc+import GHC.Unit.Module.Name as Ghc+import GHC.Unit.Types as Ghc+import GHC.Utils.Outputable as Ghc++#elif MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Names as Ghc+import GHC.Builtin.Types as Ghc+import GHC.Core.Class as Ghc+import GHC.Core.Make as Ghc+import GHC.Core.Type as Ghc+import GHC.Data.Bag as Ghc+import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.FastString as Ghc+import GHC.Driver.Finder as Ghc+import GHC.Driver.Plugins as Ghc hiding (TcPlugin)+import GHC.Driver.Session as Ghc+import GHC.Hs.Binds as Ghc+import GHC.Hs.Decls as Ghc+import GHC.Hs.Expr as Ghc+import GHC.Hs.Extension as Ghc+import GHC.Hs.Pat as Ghc+import GHC.Hs.Type as Ghc+import GHC.Iface.Env as Ghc+import GHC.LanguageExtensions as Ghc hiding (UnicodeSyntax)+import GHC.Rename.Expr as Ghc+import GHC.Tc.Types as Ghc+import GHC.Tc.Types.Constraint as Ghc+import GHC.Tc.Types.Evidence as Ghc+import GHC.Tc.Types.Origin as Ghc+import GHC.Tc.Utils.Monad as Ghc+import GHC.ThToHs as Ghc+import GHC.Types.Basic as Ghc+import GHC.Types.Name as Ghc hiding (varName)+import GHC.Types.SrcLoc as Ghc+import GHC.Types.Unique.Supply as Ghc+import GHC.Unit.Module.Name as Ghc+import GHC.Unit.Types as Ghc+import GHC.Utils.Outputable as Ghc++#elif MIN_VERSION_ghc(8,10,0)+import Bag as Ghc+import BasicTypes as Ghc+import Class as Ghc+import Constraint as Ghc+import DynFlags as Ghc+import qualified EnumSet as EnumSet+import FastString as Ghc+import Finder as Ghc+import GHC.Hs.Binds as Ghc+import GHC.Hs.Decls as Ghc+import GHC.Hs.Expr as Ghc+import GHC.Hs.Extension as Ghc+import GHC.Hs.Pat as Ghc+import GHC.Hs.Types as Ghc+import GHC.LanguageExtensions as Ghc hiding (UnicodeSyntax)+import GHC.ThToHs as Ghc+import IfaceEnv as Ghc+import MkCore as Ghc+import Module as Ghc+import Name as Ghc+import Outputable as Ghc+import Plugins as Ghc hiding (TcPlugin)+import PrelNames as Ghc+import RnExpr as Ghc+import SrcLoc as Ghc+import TcEvidence as Ghc+import TcOrigin as Ghc+import TcPluginM as Ghc hiding (findImportedModule, getTopEnv, newUnique, getEnvs, lookupOrig)+import TcRnMonad as Ghc+import Type as Ghc+import TysWiredIn as Ghc+import UniqSupply as Ghc+#endif++enumSetMember :: Enum a => a -> EnumSet.EnumSet a -> Bool+enumSetMember = EnumSet.member++pattern FunBind'+ { fun_ext'+ , fun_id'+ , fun_matches'+ } =+#if MIN_VERSION_ghc(9,0,0)+ FunBind fun_ext' fun_id' fun_matches' []+pattern FunBind'+ :: XFunBind GhcRn GhcRn+ -> LIdP GhcRn+ -> MatchGroup GhcRn (LHsExpr GhcRn)+ -> HsBindLR GhcRn GhcRn+#else+ FunBind fun_ext' fun_id' fun_matches' WpHole []+pattern FunBind'+ :: XFunBind GhcRn GhcRn+ -> Located (IdP GhcRn)+ -> MatchGroup GhcRn (LHsExpr GhcRn)+ -> HsBindLR GhcRn GhcRn+#endif++pattern HsSig' ty+#if MIN_VERSION_ghc(9,2,0)+ <- L _ (HsSig _ _ ty)+ where+ HsSig' ty = L noSrcSpanA $ HsSig NoExtField (HsOuterImplicit []) ty+pattern HsSig' :: LHsType GhcRn -> LHsSigType Ghc.GhcRn+#else+ <- HsIB _ ty+ where+ HsSig' ty = HsIB [] ty+pattern HsSig' :: LHsType GhcRn -> HsImplicitBndrs GhcRn (LHsType GhcRn)+#endif++setSigBody :: LHsType GhcRn -> LHsSigType GhcRn -> LHsSigType GhcRn+setSigBody body lsig =+#if MIN_VERSION_ghc(9,2,0)+ fmap (\s -> s { sig_body = body }) lsig+#else+ lsig { hsib_body = body }+#endif++noLocA'+#if MIN_VERSION_ghc(9,2,0)+ :: a -> LocatedAn an a+noLocA'+ = noLocA+#else+ :: a -> Located a+noLocA'+ = noLoc+#endif++emptyEpAnn+#if MIN_VERSION_ghc(9,2,0)+ :: EpAnn a+emptyEpAnn+ = noAnn+#else+ :: NoExtField+emptyEpAnn+ = NoExtField+#endif++noLoc'+#if MIN_VERSION_ghc(9,2,0)+ :: a -> a+noLoc' = id+#else+ :: a -> Located a+noLoc' = noLoc+#endif++emptyComments'+#if MIN_VERSION_ghc(9,2,0)+ :: EpAnnComments+emptyComments' = emptyComments+#else+ :: NoExtField+emptyComments' = NoExtField+#endif++pattern HsQualTy'+ :: XQualTy GhcRn+ -> Maybe (LHsContext GhcRn)+ -> LHsType GhcRn+ -> HsType GhcRn+#if MIN_VERSION_ghc(9,2,0)+pattern HsQualTy' x lctx body+ = HsQualTy x lctx body+#else+pattern HsQualTy' x lctx body+ <- HsQualTy x (Just -> lctx) body+ where+ HsQualTy' x Nothing body = HsQualTy x (noLoc []) body+ HsQualTy' x (Just lctx) body = HsQualTy x lctx body+#endif++pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc+#if MIN_VERSION_ghc(9,0,0)+pattern RealSrcLoc' loc <- RealSrcLoc loc _+#else+pattern RealSrcLoc' loc = RealSrcLoc loc+#endif++pattern L' :: SrcSpan -> a+#if MIN_VERSION_ghc(9,2,0)+ -> GenLocated (SrcSpanAnn' ann) a+pattern L' ss a <- L (SrcSpanAnn _ ss) a+#else+ -> Located a+pattern L' ss a <- L ss a+#endif
+ src/Graph/Trace/Internal/Instrument.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-} -- used in TH splice+module Graph.Trace.Internal.Instrument+ ( modifyValBinds+ , modifyTyClDecl+ , modifyClsInstDecl+ ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.CPS+import qualified Data.Generics as Syb+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import GHC.Magic (noinline)+import qualified Language.Haskell.TH as TH+import System.IO.Unsafe (unsafePerformIO)+import qualified System.Random as Rand++import qualified Graph.Trace.Internal.GhcFacade as Ghc+import Graph.Trace.Internal.Types++-- | Instrument value bindings that have a signature with a debug pred.+-- This gets applied to both top level bindings as well as arbitrarily nested+-- value bindings.+modifyValBinds+ :: DebugNames+ -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)+ -> Ghc.NHsValBindsLR Ghc.GhcRn+ -> WriterT+ (S.Set Ghc.Name)+ (StateT (S.Set Ghc.Name) Ghc.TcM)+ (Ghc.NHsValBindsLR Ghc.GhcRn)+modifyValBinds debugNames nameMap (Ghc.NValBinds binds sigs) = do+ binds' <-+ (traverse . traverse)+ (modifyBinds nameMap debugNames)+ binds+ lift $ modify' (S.union $ M.keysSet nameMap)+ pure $ Ghc.NValBinds binds' sigs++-- | Instrument default method implementations in a type class declaration if+-- they contain a Debug pred.+modifyTyClDecl+ :: DebugNames+ -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)+ -> Ghc.TyClDecl Ghc.GhcRn+ -> WriterT+ (S.Set Ghc.Name)+ (StateT (S.Set Ghc.Name) Ghc.TcM)+ (Ghc.TyClDecl Ghc.GhcRn)+modifyTyClDecl debugNames nameMap+ cd@Ghc.ClassDecl { Ghc.tcdMeths = meths+ } = do+ newMeths <- modifyBinds nameMap debugNames meths+ pure cd { Ghc.tcdMeths = newMeths }+modifyTyClDecl _ _ x = pure x++-- | Instrument the method implementations in an type class instance if it has+-- a signature containing a debug pred.+modifyClsInstDecl+ :: DebugNames+ -> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)+ -> Ghc.ClsInstDecl Ghc.GhcRn+ -> WriterT+ (S.Set Ghc.Name)+ (StateT (S.Set Ghc.Name) Ghc.TcM)+ (Ghc.ClsInstDecl Ghc.GhcRn)+modifyClsInstDecl debugNames nameMap+ inst@Ghc.ClsInstDecl{ Ghc.cid_binds = binds }+ = do+ newBinds <- modifyBinds nameMap debugNames binds+ pure inst { Ghc.cid_binds = newBinds }+#if !(MIN_VERSION_ghc(9,0,0))+modifyClsInstDecl _ _ x = pure x+#endif++-- | Instrument a set of bindings given a Map containing the names of functions+-- that should be modified.+modifyBinds+ :: M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)+ -> DebugNames+ -> Ghc.LHsBinds Ghc.GhcRn+ -> WriterT+ (S.Set Ghc.Name)+ (StateT (S.Set Ghc.Name) Ghc.TcM)+ (Ghc.LHsBinds Ghc.GhcRn)+modifyBinds nameMap debugNames =+ (traverse . traverse)+ (modifyBinding nameMap debugNames)++-- | Instrument a binding if its name is in the Map.+modifyBinding+ :: M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)+ -> DebugNames+ -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn+ -> WriterT+ (S.Set Ghc.Name)+ (StateT (S.Set Ghc.Name) Ghc.TcM)+ (Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn)+modifyBinding nameMap debugNames+ bnd@Ghc.FunBind { Ghc.fun_id = Ghc.L' loc name+ , Ghc.fun_matches = mg@(Ghc.MG _ alts _) }+ | Just (mUserKey, prop) <- M.lookup name nameMap+ = do+ let key = case mUserKey of+ Nothing -> Left $ Ghc.getOccString name+ Just k -> Right $ Ghc.unpackFS k++ whereBindExpr <- lift . lift $ mkNewIpExpr loc key prop++ newAlts <- lift $+ (traverse . traverse . traverse)+ (modifyMatch prop whereBindExpr debugNames)+ alts++ pure bnd{Ghc.fun_matches = mg{ Ghc.mg_alts = newAlts }}+modifyBinding nameMap _+ bnd@Ghc.PatBind{ Ghc.pat_lhs = pat } = do+ -- Collect the 'Name's appearing in pattern bindings so that if they have+ -- type signatures, the predicate can be removed if monomorphism+ -- restriction is on.+ let collectName :: Ghc.Pat Ghc.GhcRn -> S.Set Ghc.Name+ collectName = \case+ Ghc.VarPat _ (Ghc.unLoc -> name)+ | M.member name nameMap -> S.singleton name+ Ghc.AsPat _ (Ghc.unLoc -> name) _+ | M.member name nameMap -> S.singleton name+ _ -> mempty+ vars = Syb.everything (<>) (Syb.mkQ mempty collectName) pat+ tell vars+ pure bnd+modifyBinding _ _ bnd = pure bnd++-- | Generate the Name for the where binding+mkWhereBindName :: Ghc.TcM Ghc.Name+mkWhereBindName = do+ uniq <- Ghc.getUniqueM+ pure $ Ghc.mkSystemVarName uniq "new_debug_ip"++-- | Creates a FunBind that will be placed in the where block of a function to+-- serve as the sole definition site of the new DebugContext for that function.+mkWhereBinding :: Ghc.Name -> Ghc.LHsExpr Ghc.GhcRn -> Ghc.LHsBind Ghc.GhcRn+mkWhereBinding whereBindName whereBindExpr =+ Ghc.noLocA' Ghc.FunBind'+ { Ghc.fun_ext' = mempty+ , Ghc.fun_id' = Ghc.noLocA' whereBindName+ , Ghc.fun_matches' =+ Ghc.MG+ { Ghc.mg_ext = Ghc.NoExtField+ , Ghc.mg_alts = Ghc.noLocA'+ [Ghc.noLocA' Ghc.Match+ { Ghc.m_ext = Ghc.emptyEpAnn+ , Ghc.m_ctxt = Ghc.FunRhs+ { Ghc.mc_fun = Ghc.noLocA' whereBindName+ , Ghc.mc_fixity = Ghc.Prefix+ , Ghc.mc_strictness = Ghc.SrcStrict+ }+ , Ghc.m_pats = []+ , Ghc.m_grhss = Ghc.GRHSs+ { Ghc.grhssExt = Ghc.emptyComments'+ , Ghc.grhssGRHSs =+ [ Ghc.noLoc $ Ghc.GRHS+ Ghc.emptyEpAnn+ []+ whereBindExpr+ ]+ , Ghc.grhssLocalBinds = Ghc.noLoc' $+ Ghc.EmptyLocalBinds Ghc.NoExtField+ }+ }+ ]+ , Ghc.mg_origin = Ghc.Generated+ }+ }++-- | Add a where bind for the new value of the IP, then add let bindings to the+-- front of each GRHS to set the new value of the IP in that scope.+modifyMatch+ :: Propagation+ -> Ghc.LHsExpr Ghc.GhcRn+ -> DebugNames+ -> Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+ -> StateT (S.Set Ghc.Name) Ghc.TcM (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn))+modifyMatch prop whereBindExpr debugNames match = do+ whereBindName <- lift mkWhereBindName++ visitedNames <- get++ -- only update the where bindings that don't have Debug+ -- predicates, those that do will be addressed via recursion.+ -- It is also necesarry to descend into potential recursive wheres+ -- but the recursion needs to stop if a known name is found.+ let visitedBinding :: Ghc.HsBind Ghc.GhcRn -> Bool+ visitedBinding Ghc.FunBind{ Ghc.fun_id = Ghc.L _ funName }+ = S.member funName visitedNames+ visitedBinding _ = False+ -- Do not instrument let bindings in view patterns.+ isViewPat :: Ghc.Pat Ghc.GhcRn -> Bool+ isViewPat Ghc.ViewPat{} = True+ isViewPat _ = False++ -- recurse the entire match to add let bindings to all where clauses,+ -- including those belonging to let-bound terms at any nesting depth.+ -- Bindings must be added to let statements in do-blocks as well.+ match'@Ghc.Match+ { Ghc.m_grhss =+ grhs@Ghc.GRHSs+ { Ghc.grhssLocalBinds =+#if MIN_VERSION_ghc(9,2,0)+ whereBinds+#else+ Ghc.L whereLoc whereBinds+#endif+ , Ghc.grhssGRHSs = grhsList+ }+ } = Syb.everywhereBut+ (Syb.mkQ False visitedBinding `Syb.extQ` isViewPat) -- stop condition+ (Syb.mkT $ updateDebugIpInFunBind whereBindName)+ match++ ipValWhereBind = mkWhereBinding whereBindName whereBindExpr++ wrappedBind = (Ghc.NonRecursive, Ghc.unitBag ipValWhereBind)++ -- NOINLINE pragma. We don't want the where binding to ever be inlined+ -- because then it would generate a different ID.+ noInlineSig :: Ghc.LSig Ghc.GhcRn+ noInlineSig = Ghc.noLocA' $+ Ghc.InlineSig+ Ghc.emptyEpAnn+ (Ghc.noLocA' whereBindName)+ Ghc.neverInlinePragma++ -- Type sig for 'Maybe DebugContext'+ -- Without an explicit signature for the where binding,+ -- -XNoMonomorphismRestriction causes it to be inlined.+ whereBindSig :: Ghc.LSig Ghc.GhcRn+ whereBindSig = Ghc.noLocA' $+ Ghc.TypeSig+ Ghc.emptyEpAnn+ [Ghc.noLocA' whereBindName] $+ Ghc.HsWC [] $+ Ghc.HsSig' $+ Ghc.noLocA' $+ Ghc.HsAppTy Ghc.NoExtField+ (Ghc.noLocA' . Ghc.HsTyVar Ghc.emptyEpAnn Ghc.NotPromoted+ $ Ghc.noLocA' Ghc.maybeTyConName)+ (Ghc.noLocA' . Ghc.HsTyVar Ghc.emptyEpAnn Ghc.NotPromoted .+ Ghc.noLocA' $ debugContextName debugNames+ )++ -- add the generated bind to the function's where clause+ whereBinds' =+ case whereBinds of+ Ghc.EmptyLocalBinds _ ->+ Ghc.HsValBinds Ghc.emptyEpAnn+ (Ghc.XValBindsLR+ (Ghc.NValBinds [wrappedBind] [noInlineSig, whereBindSig])+ )++ Ghc.HsValBinds x (Ghc.XValBindsLR (Ghc.NValBinds binds sigs)) ->+ Ghc.HsValBinds x+ (Ghc.XValBindsLR+ (Ghc.NValBinds+ (wrappedBind : binds)+ (noInlineSig : whereBindSig : sigs)+ )+ )++ _ -> whereBinds++ pure match'{ Ghc.m_grhss = grhs+ { Ghc.grhssLocalBinds =+#if MIN_VERSION_ghc(9,2,0)+ whereBinds'+#else+ Ghc.L whereLoc whereBinds'+#endif+ , Ghc.grhssGRHSs =+ fmap ( updateDebugIPInGRHS whereBindName+ -- Don't emit entry event if propagation is Mute+ . if prop == Mute+ then id+ else emitEntryEvent (entryName debugNames)+ )+ <$> grhsList+ }+ }++-- | Targets function bindings that are known to not have a debug constraint+-- and then updates the definitions of those functions to add the special let+-- statement referencing the where binding.+updateDebugIpInFunBind+ :: Ghc.Name+ -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn+ -> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn+updateDebugIpInFunBind whereVarName+ b@Ghc.FunBind{ Ghc.fun_matches = m@Ghc.MG{ Ghc.mg_alts = alts } }+ = b { Ghc.fun_matches =+ m { Ghc.mg_alts = (fmap . fmap . fmap) updateMatch alts }+ }+ where+ updateMatch mtch@Ghc.Match{Ghc.m_grhss = g@Ghc.GRHSs{Ghc.grhssGRHSs = grhss}}+ = mtch{Ghc.m_grhss =+ g{Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS whereVarName) <$> grhss }+ }+#if !(MIN_VERSION_ghc(9,0,0))+ updateMatch x = x+#endif+updateDebugIpInFunBind whereVarName+ b@Ghc.PatBind{ Ghc.pat_rhs = g@Ghc.GRHSs{ Ghc.grhssGRHSs = grhss } }+ = b { Ghc.pat_rhs =+ g{ Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS whereVarName) <$> grhss }+ }+updateDebugIpInFunBind _ b = b++-- | Produce the contents of the where binding that contains the new debug IP+-- value, generated by creating a new ID and pairing it with the old one.+-- The ID is randomly generated. Could instead have a global ID sequence but+-- the random ID has the advantage that a program can be run multiple times+-- using the same log file and the traces won't conflict.+mkNewIpExpr+ :: Ghc.SrcSpan+ -> Either FunName UserKey+ -> Propagation+ -> Ghc.TcM (Ghc.LHsExpr Ghc.GhcRn)+mkNewIpExpr srcSpan newKey newProp = do+ let mDefSite = case Ghc.srcSpanStart srcSpan of+ Ghc.RealSrcLoc' loc ->+ Just SrcCodeLoc+ { srcModule = Ghc.unpackFS $ Ghc.srcLocFile loc+ , srcLine = Ghc.srcLocLine loc+ , srcCol = Ghc.srcLocCol loc+ }+ _ -> Nothing+ Right exprPs+ <- fmap (Ghc.convertToHsExpr Ghc.Generated Ghc.noSrcSpan)+ . liftIO+ $ TH.runQ [| noinline $! Just $! mkNewDebugContext mDefSite newKey newProp ?_debug_ip |]++ (exprRn, _) <- Ghc.rnLExpr exprPs++ pure exprRn++-- | Build a new debug context from the previous state. Uses unsafe IO+-- to generate a random ID associated with a particular function invocation+mkNewDebugContext+ :: Maybe DefinitionSite -- ^ Definition site of current function+ -> Either FunName UserKey -- ^ Name of the function or a key supplied by the user+ -> Propagation -- ^ propagation strategy for new context+ -> Maybe DebugContext+ -> DebugContext+mkNewDebugContext mDefSite newKey newProp mPrevCtx =+ case (mPrevCtx, newKey) of+ -- If override key matches with previous tag, keep the id+ (Just prevCtx, Right userKey)+ | debugKey (currentTag prevCtx) == Right userKey+ -> prevCtx+ { propagation = getNextProp (Just $ propagation prevCtx) }+ _ -> unsafePerformIO $ do+ newId <- Rand.randomIO :: IO Word+ let newTag = DT+ { invocationId = newId+ , debugKey = newKey+ }+ pure+ DC { previousTag = currentTag <$> mPrevCtx+ , currentTag = newTag+ , propagation = getNextProp (propagation <$> mPrevCtx)+ , definitionSite = mDefSite+ }+ where+ getNextProp Nothing = newProp+ getNextProp (Just prev) =+ case (prev, newProp) of+ (Mute, _) -> Mute+ (_, Mute) -> Mute+ (Deep, _) -> Deep+ _ -> newProp++-- | Wraps an expression with the 'entry' function. '$' is used to apply it+-- because it has same special impredicative type properties in ghc 9.2+.+emitEntryEvent+ :: Ghc.Name+ -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+ -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+emitEntryEvent emitEntryName (Ghc.GRHS x guards body) =+ Ghc.GRHS x guards . Ghc.noLocA' $+ Ghc.HsApp Ghc.emptyEpAnn+ (Ghc.noLocA' .+ Ghc.HsVar Ghc.NoExtField $ Ghc.noLocA' emitEntryName+ )+ body+#if !(MIN_VERSION_ghc(9,0,0))+emitEntryEvent _ x = x+#endif++-- | Given the name of the variable to assign to the debug IP, create a let+-- expression as a guard statement that updates the IP in that scope.+updateDebugIPInGRHS+ :: Ghc.Name+ -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+ -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+updateDebugIPInGRHS whereBindName (Ghc.GRHS x guards body)+ = Ghc.GRHS x (ipUpdateGuard : guards) body+ where+ ipUpdateGuard =+ Ghc.noLocA' $+ Ghc.LetStmt Ghc.emptyEpAnn $+ Ghc.noLoc' $+ Ghc.HsIPBinds Ghc.emptyEpAnn $+ Ghc.IPBinds Ghc.NoExtField+ [ Ghc.noLocA' $ Ghc.IPBind+ Ghc.emptyEpAnn+ (Left . Ghc.noLoc $ Ghc.HsIPName "_debug_ip")+ (Ghc.noLocA' . Ghc.HsVar Ghc.NoExtField+ $ Ghc.noLocA' whereBindName+ )+ ]+#if !(MIN_VERSION_ghc(9,0,0))+updateDebugIPInGRHS _ x = x+#endif++-- ppr :: Ghc.Outputable a => a -> String+-- ppr = Ghc.showSDocUnsafe . Ghc.ppr
+ src/Graph/Trace/Internal/Predicates.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+module Graph.Trace.Internal.Predicates+ ( removeConstraints+ , addConstraintToSig+ ) where++import Control.Monad.Trans.Writer.CPS+import qualified Data.Generics as Syb+import qualified Data.List as L+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Set as S++import qualified Graph.Trace.Internal.GhcFacade as Ghc+import Graph.Trace.Internal.Types++-- | Removes debug predicates from the type signatures in an expression.+-- This is necessary if there are type signatures for pattern bound names and+-- the monomorphism restriction is on.+removeConstraints :: Syb.Data a => DebugNames -> S.Set Ghc.Name -> a -> a+removeConstraints debugNames targetNames thing+ | S.null targetNames = thing+ | otherwise = Syb.mkT processBind `Syb.everywhere` thing+ where+ processBind :: Ghc.HsValBinds Ghc.GhcRn -> Ghc.HsValBinds Ghc.GhcRn+ processBind (Ghc.XValBindsLR (Ghc.NValBinds binds sigs)) =+ Ghc.XValBindsLR (Ghc.NValBinds binds (concatMap removeConstraint sigs))+ processBind binds = binds+ removeConstraint (Ghc.L loc (Ghc.TypeSig x1 names sig)) =+ let (targeted, inert) =+ L.partition ((`S.member` targetNames) . Ghc.unLoc) names+ in [ Ghc.noLocA' . Ghc.TypeSig x1 targeted+ $ Syb.mkT removePred `Syb.everywhere` sig+ , Ghc.L loc $ Ghc.TypeSig x1 inert sig+ ]+ removeConstraint s = [s]+ removePred (Ghc.HsQualTy' x ctx body) =+ let newCtx = (fmap . fmap) (filter (notDebugPred . Ghc.unLoc)) ctx+ in Ghc.HsQualTy' x newCtx body+ removePred x = x+ notDebugPred = isNothing . checkForDebugPred debugNames++-- | Matches on type signatures in order to add the constraint to them.+addConstraintToSig+ :: DebugNames+ -> Bool -- True <=> Debug all functions+ -> Ghc.Sig Ghc.GhcRn+ -> Writer (M.Map Ghc.Name (Maybe Ghc.FastString, Propagation))+ (Ghc.Sig Ghc.GhcRn)+addConstraintToSig debugNames debugAllFlag+ (Ghc.TypeSig x1 lNames (Ghc.HsWC x2 sig)) = do+ sig' <- addConstraintToSigType debugNames debugAllFlag (Ghc.unLoc <$> lNames) sig+ pure $ Ghc.TypeSig x1 lNames (Ghc.HsWC x2 sig')+addConstraintToSig debugNames debugAllFlag+ (Ghc.ClassOpSig x1 b lNames sig) = do+ sig' <- addConstraintToSigType debugNames debugAllFlag (Ghc.unLoc <$> lNames) sig+ pure $ Ghc.ClassOpSig x1 b lNames sig'+addConstraintToSig _ _ s = pure s++-- | Adds the 'Debug' constraint to a signature if it doesn't already have it+-- as the first constraint in the context.+addConstraintToSigType+ :: DebugNames+ -> Bool -- True <=> Debug all functions+ -> [Ghc.Name]+ -> Ghc.LHsSigType Ghc.GhcRn+ -> Writer (M.Map Ghc.Name (Maybe Ghc.FastString, Propagation))+ (Ghc.LHsSigType Ghc.GhcRn)+addConstraintToSigType debugNames debugAllFlag names sig@(Ghc.HsSig' t) = do+ sigBody <- traverse go t+ pure $ Ghc.setSigBody sigBody sig+ where+ prop = if debugAllFlag then Shallow else Inert+ predName =+ if debugAllFlag+ then tracePredName debugNames+ else traceInertPredName debugNames+ predTy = Ghc.noLocA'+ $ Ghc.HsTyVar Ghc.emptyEpAnn Ghc.NotPromoted+ (Ghc.noLocA' predName)+ go ty =+ case ty of+ x@Ghc.HsForAllTy { Ghc.hst_body = body } -> do+ body' <- traverse go body+ pure $ x { Ghc.hst_body = body' }+ q@(Ghc.HsQualTy' x ctx body)+ | foundPred : _ <-+ mapMaybe (checkForDebugPred debugNames)+ (Ghc.unLoc <$> foldMap Ghc.unLoc ctx)+ -- Note that DebugMuted bindings should still be included because+ -- the muted status needs to be inherited by the functions called from it+ -> do tell (M.fromList $ names `zip` repeat foundPred)+ pure q+ | otherwise -> do+ tell (M.fromList $ names `zip` repeat (Nothing, prop))+ pure $+ Ghc.HsQualTy'+ x+ (Just $ maybe (Ghc.noLocA' [predTy])+ (fmap (predTy :))+ ctx+ )+ body+ _ -> do+ tell (M.fromList $ names `zip` repeat (Nothing, prop))+ pure $+ Ghc.HsQualTy'+ Ghc.NoExtField+ (Just $ Ghc.noLocA' [predTy])+ (Ghc.noLocA' ty)+addConstraintToSigType _ _ _ x = pure x++-- | Check if a type has a debug predicate in it's context. If so, return the+-- override key if supplied and the propagation strategy.+checkForDebugPred+ :: DebugNames+ -> Ghc.HsType Ghc.GhcRn+ -> Maybe (Maybe Ghc.FastString, Propagation)+checkForDebugPred debugNames+ (Ghc.HsTyVar _ _ (Ghc.L _ name))+ | name == tracePredName debugNames = Just (Nothing, Shallow)+ | name == traceDeepPredName debugNames = Just (Nothing, Deep)+ | name == traceMutePredName debugNames = Just (Nothing, Mute)+ | name == traceInertPredName debugNames = Just (Nothing, Inert)+checkForDebugPred debugNames+ (Ghc.HsAppTy _ (Ghc.L _ (Ghc.HsTyVar _ _ (Ghc.L _ name))) (Ghc.L _ (Ghc.HsTyLit _ (Ghc.HsStrTy _ key))))+ | name == traceKeyPredName debugNames = Just (Just key, Shallow)+ | name == traceDeepKeyPredName debugNames = Just (Just key, Deep)+checkForDebugPred debugNames Ghc.HsForAllTy { Ghc.hst_body = Ghc.L _ ty }+ = checkForDebugPred debugNames ty+checkForDebugPred debugNames (Ghc.HsParTy _ (Ghc.L _ ty))+ = checkForDebugPred debugNames ty+checkForDebugPred _ _ = Nothing+-- need a case for nested QualTy?
+ src/Graph/Trace/Internal/RuntimeRep.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if MIN_VERSION_ghc(9,0,0)+{-# LANGUAGE LinearTypes #-}+#endif+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Graph.Trace.Internal.RuntimeRep+ ( LPId(..)+ ) where++import GHC.Exts+#if MIN_VERSION_ghc(9,0,0)+import GHC.Types (Multiplicity(..))+#endif++-- | Levity polymorphic id function. Doesn't cover all runtime reps, in+-- particular unboxed products and sums. Handles linearity as well.+#if MIN_VERSION_ghc(9,0,0)+class LPId (r :: RuntimeRep) (m :: Multiplicity) where+ lpId :: forall (a :: TYPE r). a %m -> a+#else+class LPId (r :: RuntimeRep) where+ lpId :: forall (a :: TYPE r). a -> a+#endif++#if MIN_VERSION_ghc(9,0,0)+instance LPId LiftedRep One where+ lpId x = x+instance LPId LiftedRep Many where+ lpId x = x+instance LPId UnliftedRep One where+ lpId x = x+instance LPId UnliftedRep Many where+ lpId x = x+instance LPId IntRep One where+ lpId x = x+instance LPId IntRep Many where+ lpId x = x+instance LPId Int8Rep One where+ lpId x = x+instance LPId Int8Rep Many where+ lpId x = x+instance LPId Int16Rep One where+ lpId x = x+instance LPId Int16Rep Many where+ lpId x = x+instance LPId Int32Rep One where+ lpId x = x+instance LPId Int32Rep Many where+ lpId x = x+instance LPId Int64Rep One where+ lpId x = x+instance LPId Int64Rep Many where+ lpId x = x+instance LPId WordRep One where+ lpId x = x+instance LPId WordRep Many where+ lpId x = x+instance LPId Word8Rep One where+ lpId x = x+instance LPId Word8Rep Many where+ lpId x = x+instance LPId Word16Rep One where+ lpId x = x+instance LPId Word16Rep Many where+ lpId x = x+instance LPId Word32Rep One where+ lpId x = x+instance LPId Word32Rep Many where+ lpId x = x+instance LPId Word64Rep One where+ lpId x = x+instance LPId Word64Rep Many where+ lpId x = x+instance LPId AddrRep One where+ lpId x = x+instance LPId AddrRep Many where+ lpId x = x+instance LPId FloatRep One where+ lpId x = x+instance LPId FloatRep Many where+ lpId x = x+instance LPId DoubleRep One where+ lpId x = x+instance LPId DoubleRep Many where+ lpId x = x+#else+instance LPId LiftedRep where+ lpId = id+instance LPId UnliftedRep where+ lpId x = x+instance LPId IntRep where+ lpId x = x+instance LPId Int8Rep where+ lpId x = x+instance LPId Int16Rep where+ lpId x = x+instance LPId Int32Rep where+ lpId x = x+instance LPId Int64Rep where+ lpId x = x+instance LPId WordRep where+ lpId x = x+instance LPId Word8Rep where+ lpId x = x+instance LPId Word16Rep where+ lpId x = x+instance LPId Word32Rep where+ lpId x = x+instance LPId Word64Rep where+ lpId x = x+instance LPId AddrRep where+ lpId x = x+instance LPId FloatRep where+ lpId x = x+instance LPId DoubleRep where+ lpId x = x+#endif
+ src/Graph/Trace/Internal/Solver.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Graph.Trace.Internal.Solver+ ( tcPlugin+ ) where++import qualified Graph.Trace.Internal.GhcFacade as Ghc++tcPlugin :: Ghc.TcPlugin+tcPlugin =+ Ghc.TcPlugin+ { Ghc.tcPluginInit = pure ()+ , Ghc.tcPluginStop = \_ -> pure ()+ , Ghc.tcPluginSolve = const tcPluginSolver+ }++debuggerIpKey :: Ghc.FastString+debuggerIpKey = "_debug_ip"++isDebuggerIpCt :: Ghc.Ct -> Bool+isDebuggerIpCt ct@Ghc.CDictCan{}+ | Ghc.className (Ghc.cc_class ct) == Ghc.ipClassName+ , ty : _ <- Ghc.cc_tyargs ct+ , Just ipKey <- Ghc.isStrLitTy ty+ , ipKey == debuggerIpKey+ = True+isDebuggerIpCt _ = False++tcPluginSolver :: Ghc.TcPluginSolver+tcPluginSolver _ [] wanted = do+ case filter isDebuggerIpCt wanted of+ [w]+ | Ghc.IPOccOrigin _ <- Ghc.ctl_origin . Ghc.ctev_loc $ Ghc.cc_ev w+ -> do+ -- This occurs when the IP constraint is satisfied but a wanted still+ -- gets emitted for the a use site of the IP variable (why?).+ -- We don't want to touch this constraint because the value for the IP+ -- should be inherited from the context.+ pure $ Ghc.TcPluginOk [] []+ | otherwise+ -> do+ -- This occurs when the IP constraint is not satisfiable by the context.+ -- Here we want to manually construct a value with which to satisfy it.+ let expr = Ghc.mkNothingExpr Ghc.anyTy+ pure $ Ghc.TcPluginOk [(Ghc.EvExpr expr, w)] []+ _ -> pure $ Ghc.TcPluginOk [] []+tcPluginSolver _ _ _ = pure $ Ghc.TcPluginOk [] []
+ src/Graph/Trace/Internal/Trace.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE CPP #-}+# if MIN_VERSION_ghc(9,0,0)+{-# LANGUAGE LinearTypes #-}+# endif+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE BangPatterns #-}+module Graph.Trace.Internal.Trace+ ( trace+ , traceId+ , traceShow+ , traceShowId+ , traceM+ , traceShowM+ , entry+ , omitTraces+ ) where++import Control.Concurrent.MVar+import Control.Monad+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8+import GHC.Exts+import GHC.Stack (callStack, popCallStack)+import System.Environment (getProgName, lookupEnv)+import System.IO+import System.IO.Unsafe (unsafePerformIO)++import Graph.Trace.Internal.RuntimeRep (LPId(..))+import Graph.Trace.Internal.Types++mkTraceEvent :: DebugIP => String -> Maybe Event+mkTraceEvent !msg = do+ ip <- ?_debug_ip+ guard . not $ omitTraces (propagation ip)+ pure $+ TraceEvent+ (currentTag ip)+ (BSL8.pack msg)+ (callStackToCallSite . popCallStack $ popCallStack callStack)++writeEventToLog :: Event -> IO ()+-- forcing msg is required here since the file MVar could be entagled with it+writeEventToLog event = seq fileLock $+ withMVar fileLock $ \h ->+ BSL.hPut h . (<> "\n") $ eventToLogStr event++unsafeWriteTrace :: DebugIP => String -> a -> a+unsafeWriteTrace !msg thing =+ unsafePerformIO $ do+ case mkTraceEvent msg of+ Nothing -> pure ()+ Just event -> writeEventToLog event+ pure thing+{-# NOINLINE unsafeWriteTrace #-}++trace :: DebugIP => String -> a -> a+trace = unsafeWriteTrace+{-# NOINLINE trace #-}++traceId :: DebugIP => String -> String+traceId = join unsafeWriteTrace++traceShow :: (DebugIP, Show a) => a -> b -> b+traceShow = unsafeWriteTrace . show++traceShowId :: (DebugIP, Show a) => a -> a+traceShowId = join (unsafeWriteTrace . show)++traceM :: (Applicative f, DebugIP) => String -> f ()+traceM x = unsafeWriteTrace x $ pure ()++traceShowM :: (Applicative f, Show a, DebugIP) => a -> f ()+traceShowM x = unsafeWriteTrace (show x) $ pure ()++-- | Serializes access to the debug log file+fileLock :: MVar Handle+fileLock = unsafePerformIO $ do+ -- check for env variable with file name+ mOverrideFileName <- lookupEnv "GRAPH_TRACE_FILENAME"+ logFilePath <-+ case mOverrideFileName of+ Nothing -> do+ progName <- getProgName+ pure $ progName <> ".trace"+ Just n -> pure n+ h <- openFile logFilePath AppendMode+ hSetBuffering h NoBuffering+ newMVar h+{-# NOINLINE fileLock #-}++-- | Emits a message to the log signaling a function invocation+entry+#if MIN_VERSION_ghc(9,0,0)+ :: forall rep m (a :: TYPE rep). (DebugIP, LPId rep m)+ => a %m -> a+#else+ :: forall rep (a :: TYPE rep). (DebugIP, LPId rep)+ => a -> a+#endif+entry =+ case ?_debug_ip of+ Nothing -> lpId+ Just ip+ | omitTraces (propagation ip) -> lpId+ | otherwise ->+ let !() = unsafePerformIO $ do+ withMVar fileLock $ \h -> do+ let ev = EntryEvent+ (currentTag ip)+ (previousTag ip)+ (definitionSite ip)+ -- need to call popCallStack here to get actual call site+ (callStackToCallSite $ popCallStack callStack)+ BSL.hPut h . (<> "\n") $ eventToLogStr ev+ in lpId+{-# NOINLINE entry #-}++omitTraces :: Propagation -> Bool+omitTraces Mute = True+omitTraces Inert = True+omitTraces _ = False++-- TODO allow to apply a function to mute some specific thing+-- mute :: DebugIP => a -> a
+ src/Graph/Trace/Internal/Types.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ImplicitParams #-}+module Graph.Trace.Internal.Types+ ( DebugTag(..)+ , DebugContext(..)+ , Propagation(..)+ , SrcCodeLoc(..)+ , DefinitionSite+ , CallSite+ , DebugIP+ , TraceMute+ , TraceDeep+ , TraceDeepKey+ , Trace+ , TraceKey+ , TraceInert+ , Event(..)+ , eventToLogStr+ , FunName+ , UserKey+ , SrcModule+ , SrcLine+ , SrcCol+ , callStackToCallSite+ , DebugNames(..)+ ) where++import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8+import GHC.Stack+import GHC.TypeLits+import qualified Language.Haskell.TH.Syntax as TH++import qualified Graph.Trace.Internal.GhcFacade as Ghc++data Propagation+ = Mute -- ^ Does not output traces, overrides other options+ | Inert -- ^ Does not output traces, doesn't override other options+ | Shallow -- ^ Outputs traces for current scope, but does not propagate+ | Deep -- ^ Outputs traces and propagates to descendents+ deriving (Eq, Show, TH.Lift)++data DebugContext =+ DC { previousTag :: !(Maybe DebugTag)+ , currentTag :: {-# UNPACK #-} !DebugTag+ , propagation :: !Propagation+ , definitionSite :: !(Maybe DefinitionSite)+ }++data SrcCodeLoc =+ SrcCodeLoc+ { srcModule :: !SrcModule+ , srcLine :: !SrcLine+ , srcCol :: !SrcCol+ } deriving TH.Lift++type SrcModule = String+type SrcLine = Int+type SrcCol = Int++type DefinitionSite = SrcCodeLoc+type CallSite = SrcCodeLoc++type DebugIP = (?_debug_ip :: Maybe DebugContext, HasCallStack)+type TraceMute = DebugIP+type TraceDeep = DebugIP+type TraceDeepKey (key :: Symbol) = DebugIP+type Trace = DebugIP+type TraceKey (key :: Symbol) = DebugIP+type TraceInert = DebugIP+-- These are String because they need to be lifted into TH expressions+type FunName = String+type UserKey = String+type MessageContent = BSL.ByteString++data DebugTag =+ DT { invocationId :: {-# UNPACK #-} !Word -- a unique identifier for a particular invocation of a function+ , debugKey :: Either FunName UserKey+ -- The name of the function containing the current execution context+ }++data Event+ = EntryEvent+ !DebugTag -- ^ Current context+ !(Maybe DebugTag) -- ^ caller's context+ !(Maybe DefinitionSite)+ !(Maybe CallSite)+ | TraceEvent+ !DebugTag+ !MessageContent+ !(Maybe CallSite)++callStackToCallSite :: CallStack -> Maybe CallSite+callStackToCallSite cs =+ case getCallStack cs of+ (_, srcLoc) : _ ->+ Just SrcCodeLoc+ { srcModule = srcLocFile srcLoc+ , srcLine = srcLocStartLine srcLoc+ , srcCol = srcLocStartCol srcLoc+ }+ _ -> Nothing++-- | Serialize an Event. The § character is used as both a separator and+-- terminator. Don't use this character in trace messages, it will break!+eventToLogStr :: Event -> BSL.ByteString+eventToLogStr (EntryEvent current mPrevious mDefSite mCallSite) =+ BSL8.intercalate "§"+ [ "entry"+ , keyStr current+ , BSL8.pack . show $ invocationId current+ , maybe "" keyStr mPrevious+ , maybe "" (BSL8.pack . show . invocationId) mPrevious+ , srcCodeLocToLogStr mDefSite+ , srcCodeLocToLogStr mCallSite+ ] <> "§"+eventToLogStr (TraceEvent current message mCallSite) =+ BSL8.intercalate "§"+ [ "trace"+ , keyStr current+ , BSL8.pack . show $ invocationId current+ , message+ , srcCodeLocToLogStr mCallSite+ ] <> "§"++srcCodeLocToLogStr :: Maybe SrcCodeLoc -> BSL.ByteString+srcCodeLocToLogStr mLoc =+ BSL8.intercalate "§"+ [ foldMap (BSL8.pack . srcModule) mLoc+ , foldMap (BSL8.pack . show . srcLine) mLoc+ , foldMap (BSL8.pack . show . srcCol) mLoc+ ]++keyStr :: DebugTag -> BSL.ByteString+keyStr+ = either+ BSL8.pack+ BSL8.pack+ . debugKey++data DebugNames =+ DebugNames+ { traceMutePredName :: Ghc.Name+ , traceDeepPredName :: Ghc.Name+ , traceDeepKeyPredName :: Ghc.Name+ , tracePredName :: Ghc.Name+ , traceKeyPredName :: Ghc.Name+ , traceInertPredName :: Ghc.Name+ , entryName :: Ghc.Name+ , debugContextName :: Ghc.Name+ }