diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for graph-trace
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/graph-trace.cabal b/graph-trace.cabal
new file mode 100644
--- /dev/null
+++ b/graph-trace.cabal
@@ -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
diff --git a/src/Graph/Trace.hs b/src/Graph/Trace.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace.hs
@@ -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)
diff --git a/src/Graph/Trace/Internal/GhcFacade.hs b/src/Graph/Trace/Internal/GhcFacade.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/GhcFacade.hs
@@ -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
diff --git a/src/Graph/Trace/Internal/Instrument.hs b/src/Graph/Trace/Internal/Instrument.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/Instrument.hs
@@ -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
diff --git a/src/Graph/Trace/Internal/Predicates.hs b/src/Graph/Trace/Internal/Predicates.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/Predicates.hs
@@ -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?
diff --git a/src/Graph/Trace/Internal/RuntimeRep.hs b/src/Graph/Trace/Internal/RuntimeRep.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/RuntimeRep.hs
@@ -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
diff --git a/src/Graph/Trace/Internal/Solver.hs b/src/Graph/Trace/Internal/Solver.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/Solver.hs
@@ -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 [] []
diff --git a/src/Graph/Trace/Internal/Trace.hs b/src/Graph/Trace/Internal/Trace.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/Trace.hs
@@ -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
diff --git a/src/Graph/Trace/Internal/Types.hs b/src/Graph/Trace/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Graph/Trace/Internal/Types.hs
@@ -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
+    }