Merge pull request #13 from well-typed/edsko/callback

Support callbacks

README.md

@@ -1,6 +1,7 @@
-# `provenance`: utilities for tracking provenance
-
-This package provides utilities that can help track when and where things are
-defined, to aid debugging. It also provides some utilities for non-interleaved
-output, for debugging concurrent code.
+# `debuggable`: utilities for making your applications more debuggable.
 
+This package provides various utilities that can be used to make your
+application easier to debug. Some of these tools are intended for use during
+actual debugging only (similar to `Debug.Trace`, for example). Other tools can
+be used as a regular component in your application, to facilitate debugging if
+and when necessary, but always present in your code.

debuggable.cabal

@@ -28,15 +28,19 @@ common lang
   build-depends:    base >= 4.14 && < 4.21
 
   default-extensions:
+      BangPatterns
       DeriveAnyClass
       DeriveFunctor
       DeriveGeneric
       DerivingStrategies
       GeneralizedNewtypeDeriving
+      LambdaCase
       NamedFieldPuns
+      RankNTypes
       ScopedTypeVariables
       StandaloneDeriving
       TupleSections
+      TypeApplications
 
 library
   import:         lang
@@ -47,6 +51,7 @@ library
     Debug.NonInterleavedIO.Scoped
     Debug.NonInterleavedIO.Trace
     Debug.Provenance
+    Debug.Provenance.Callback
     Debug.Provenance.Scope
 
   build-depends:
@@ -55,3 +60,6 @@ library
     , hashable             >= 1.4   && < 1.6
     , temporary            >= 1.2.1 && < 1.4
     , unordered-containers >= 0.2   && < 0.3
+
+  other-extensions:
+      ImplicitParams

src/Debug/Provenance/Callback.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -ddump-to-file #-}
+
+-- | Provenance for callbacks
+module Debug.Provenance.Callback (
+    Callback -- opaque
+  , callback
+  , invokeCallback
+  ) where
+
+import GHC.Stack
+
+import Debug.Provenance
+
+{-------------------------------------------------------------------------------
+  Callback
+-------------------------------------------------------------------------------}
+
+-- | Callback of type @(a -> m b)@
+--
+-- When we invoke a callback, it is useful to distinguish between two things:
+--
+-- * The 'CallStack' of the /invocation/ of the callback
+-- * The 'CallSite' of the /definition/ of the callback
+--
+-- The purpose of this module is to be careful about this distinction; a
+-- 'HasCallStack' backtrace originating from an invocation of a callback will
+-- look something like this:
+--
+-- > gM, called at ..
+-- > ..
+-- > g2, called at ..
+-- > g1, called at ..
+-- > callbackFn, called at ..
+-- > invoking callback defined at <callSite>
+-- > invokeCallback, called at ..
+-- > fN, called at ..
+-- > ..
+-- > f2, called at ..
+-- > f1, called at ..
+--
+-- where
+--
+-- * @f1 .. fN@ are the function calls leading up to the callback
+-- * @g1 .. gM@ are the function calls made inside of the callback
+-- * @\<callSite\>@ tells us where the callback was defined
+newtype Callback m a b = Wrap (Callback_ CallStack m a b)
+
+-- | Define 'Callback'
+--
+-- See 'Callback' for discussion and motivation of the /two/ 'HasCallStack'
+-- constraints.
+callback :: HasCallStack => (HasCallStack => a -> m b) -> Callback m a b
+callback callbackFn = withFrozenCallStack $ Wrap (callback_ callbackFn)
+
+-- | Invoke 'Callback'
+invokeCallback :: HasCallStack => Callback m a b -> a -> m b
+invokeCallback (Wrap cb) a = invoke_ aux cb a
+  where
+    aux :: CallSite -> CallStack -> CallStack
+    aux defSite = mapCallSites $ \cs ->
+        case cs of
+          (_, loc):cs' -> -- this is the call to invoke_
+              ( "invoking callback defined at " ++ prettyCallSite defSite
+              , loc
+              )
+            : cs'
+          _otherwise ->
+            error $ "invokeCallback: unexpected CallStack"
+
+{-# NOINLINE callback #-}
+{-# NOINLINE invokeCallback #-}
+
+{-------------------------------------------------------------------------------
+  Internal: generalize over 'CallStack'
+
+  By working with a polymorphic @cs@ instead of 'CallStack' here, we avoid
+  @ghc@ manipulating the 'CallStack' itself. (This of course means that we
+  depend on the fact that 'HasCallStack' is defined as an implicit parameter.)
+-------------------------------------------------------------------------------}
+
+data Callback_ cs m a b = Callback_ {
+      callbackFunction :: !(cs -> a -> m b)
+    , callbackDefSite  :: !CallSite
+    }
+
+callback_ :: forall cs m a b.
+     HasCallStack
+  => ((?callStack :: cs) => a -> m b)
+  -> Callback_ cs m a b
+callback_ f = Callback_ (mkExplicit f) callSite
+
+invoke_ ::
+     (?callStack :: cs)
+  => (CallSite -> cs -> cs)
+  -> Callback_ cs m a b -> a -> m b
+invoke_ g Callback_{callbackFunction = fn, callbackDefSite = defSite} a =
+    mkImplicit (\cs -> fn (g defSite cs) a)
+
+mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a)
+mkExplicit f cs = let ?callStack = cs in f
+
+mkImplicit :: (?callStack :: cs) => (cs -> a) -> a
+mkImplicit f = f ?callStack
+
+{-# NOINLINE callback_  #-}
+{-# NOINLINE invoke_    #-}
+{-# NOINLINE mkExplicit #-}
+{-# NOINLINE mkImplicit #-}
+
+{-------------------------------------------------------------------------------
+  Internal: manipulating the callstack
+-------------------------------------------------------------------------------}
+
+mapCallSites ::
+     ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
+  -> CallStack -> CallStack
+mapCallSites f = fromCallSiteList . f . getCallStack

src/Debug/Provenance/Scope.hs

@@ -97,7 +97,9 @@ pushInvocation :: MonadIO m => Invocation -> m ()
 pushInvocation i = modifyThreadLocalScope_ (i:)
 
 popInvocation :: MonadIO m => m ()
-popInvocation = modifyThreadLocalScope_ tail
+popInvocation = modifyThreadLocalScope_ $ \case
+    []  -> error "popInvocation: empty stack"
+    _:s -> s
 
 {-------------------------------------------------------------------------------
   Internal: globals