|
| 1 | +{-# LANGUAGE ImplicitParams #-} |
| 2 | +{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -ddump-to-file #-} |
| 3 | + |
| 4 | +-- | Provenance for callbacks |
| 5 | +module Debug.Provenance.Callback ( |
| 6 | + Callback -- opaque |
| 7 | + , callback |
| 8 | + , invokeCallback |
| 9 | + ) where |
| 10 | + |
| 11 | +import GHC.Stack |
| 12 | + |
| 13 | +import Debug.Provenance |
| 14 | + |
| 15 | +{------------------------------------------------------------------------------- |
| 16 | + Callback |
| 17 | +-------------------------------------------------------------------------------} |
| 18 | + |
| 19 | +-- | Callback of type @(a -> m b)@ |
| 20 | +-- |
| 21 | +-- When we invoke a callback, it is useful to distinguish between two things: |
| 22 | +-- |
| 23 | +-- * The 'CallStack' of the /invocation/ of the callback |
| 24 | +-- * The 'CallSite' of the /definition/ of the callback |
| 25 | +-- |
| 26 | +-- The purpose of this module is to be careful about this distinction; a |
| 27 | +-- 'HasCallStack' backtrace originating from an invocation of a callback will |
| 28 | +-- look something like this: |
| 29 | +-- |
| 30 | +-- > gM, called at .. |
| 31 | +-- > .. |
| 32 | +-- > g2, called at .. |
| 33 | +-- > g1, called at .. |
| 34 | +-- > callbackFn, called at .. |
| 35 | +-- > invoking callback defined at <callSite> |
| 36 | +-- > invokeCallback, called at .. |
| 37 | +-- > fN, called at .. |
| 38 | +-- > .. |
| 39 | +-- > f2, called at .. |
| 40 | +-- > f1, called at .. |
| 41 | +-- |
| 42 | +-- where |
| 43 | +-- |
| 44 | +-- * @f1 .. fN@ are the function calls leading up to the callback |
| 45 | +-- * @g1 .. gM@ are the function calls made inside of the callback |
| 46 | +-- * @\<callSite\>@ tells us where the callback was defined |
| 47 | +newtype Callback m a b = Wrap (Callback_ CallStack m a b) |
| 48 | + |
| 49 | +-- | Define 'Callback' |
| 50 | +-- |
| 51 | +-- See 'Callback' for discussion and motivation of the /two/ 'HasCallStack' |
| 52 | +-- constraints. |
| 53 | +callback :: HasCallStack => (HasCallStack => a -> m b) -> Callback m a b |
| 54 | +callback callbackFn = withFrozenCallStack $ Wrap (callback_ callbackFn) |
| 55 | + |
| 56 | +-- | Invoke 'Callback' |
| 57 | +invokeCallback :: HasCallStack => Callback m a b -> a -> m b |
| 58 | +invokeCallback (Wrap cb) a = invoke_ aux cb a |
| 59 | + where |
| 60 | + aux :: CallSite -> CallStack -> CallStack |
| 61 | + aux defSite = mapCallSites $ \cs -> |
| 62 | + case cs of |
| 63 | + (_, loc):cs' -> -- this is the call to invoke_ |
| 64 | + ( "invoking callback defined at " ++ prettyCallSite defSite |
| 65 | + , loc |
| 66 | + ) |
| 67 | + : cs' |
| 68 | + _otherwise -> |
| 69 | + error $ "invokeCallback: unexpected CallStack" |
| 70 | + |
| 71 | +{-# NOINLINE callback #-} |
| 72 | +{-# NOINLINE invokeCallback #-} |
| 73 | + |
| 74 | +{------------------------------------------------------------------------------- |
| 75 | + Internal: generalize over 'CallStack' |
| 76 | +
|
| 77 | + By working with a polymorphic @cs@ instead of 'CallStack' here, we avoid |
| 78 | + @ghc@ manipulating the 'CallStack' itself. (This of course means that we |
| 79 | + depend on the fact that 'HasCallStack' is defined as an implicit parameter.) |
| 80 | +-------------------------------------------------------------------------------} |
| 81 | + |
| 82 | +data Callback_ cs m a b = Callback_ { |
| 83 | + callbackFunction :: !(cs -> a -> m b) |
| 84 | + , callbackDefSite :: !CallSite |
| 85 | + } |
| 86 | + |
| 87 | +callback_ :: forall cs m a b. |
| 88 | + HasCallStack |
| 89 | + => ((?callStack :: cs) => a -> m b) |
| 90 | + -> Callback_ cs m a b |
| 91 | +callback_ f = Callback_ (mkExplicit f) callSite |
| 92 | + |
| 93 | +invoke_ :: |
| 94 | + (?callStack :: cs) |
| 95 | + => (CallSite -> cs -> cs) |
| 96 | + -> Callback_ cs m a b -> a -> m b |
| 97 | +invoke_ g Callback_{callbackFunction = fn, callbackDefSite = defSite} a = |
| 98 | + mkImplicit (\cs -> fn (g defSite cs) a) |
| 99 | + |
| 100 | +mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a) |
| 101 | +mkExplicit f cs = let ?callStack = cs in f |
| 102 | + |
| 103 | +mkImplicit :: (?callStack :: cs) => (cs -> a) -> a |
| 104 | +mkImplicit f = f ?callStack |
| 105 | + |
| 106 | +{-# NOINLINE callback_ #-} |
| 107 | +{-# NOINLINE invoke_ #-} |
| 108 | +{-# NOINLINE mkExplicit #-} |
| 109 | +{-# NOINLINE mkImplicit #-} |
| 110 | + |
| 111 | +{------------------------------------------------------------------------------- |
| 112 | + Internal: manipulating the callstack |
| 113 | +-------------------------------------------------------------------------------} |
| 114 | + |
| 115 | +mapCallSites :: |
| 116 | + ([([Char], SrcLoc)] -> [([Char], SrcLoc)]) |
| 117 | + -> CallStack -> CallStack |
| 118 | +mapCallSites f = fromCallSiteList . f . getCallStack |
0 commit comments