content: {-# LANGUAGE ImplicitParams #-}
  
  -- | Provenance for callbacks
  module Debug.Provenance.Callback (
      -- * Callbacks
      Callback -- opaque
    , callback
    , invokeCallback
      -- *** Convenience re-exports
    , HasCallStack
    ) where
  
  import Data.Maybe (fromMaybe)
  import GHC.Stack
  
  import Debug.Provenance.Internal
  
  {-------------------------------------------------------------------------------
    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 = Wrap (callback_ callSite callbackFn)
  
  -- | Invoke 'Callback'
  invokeCallback :: HasCallStack => Callback m a b -> a -> m b
  invokeCallback (Wrap cb) a =
      callbackFunction (aux callStack) a
    where
      Callback_{callbackFunction, callbackDefSite} = cb
  
      aux :: CallStack -> CallStack
      aux = mapCallSites $ \cs ->
          case cs of
            (_, loc):cs' -> -- this is the call to invokeCallback
                ( concat [
                      "invoking callback defined at "
                      -- callee is 'callback', no point showing that
                    , fromMaybe "{unknown}" $
                        callSiteCaller callbackDefSite
                    , maybe "" (\l -> " (" ++ briefSrcLoc l ++ ")") $
                        callSiteSrcLoc callbackDefSite
  
                    ]
                  --      "invoking callback defined at "
                  -- ++ prettyCallSite callbackDefSite
                , loc
                )
              : cs'
            [] ->
              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.
       CallSite
    -> ((?callStack :: cs) => a -> m b)
    -> Callback_ cs m a b
  callback_ defSite f = Callback_ (mkExplicit f) defSite
  
  mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a)
  mkExplicit f cs = let ?callStack = cs in f
  
  {-# NOINLINE callback_  #-}
  {-# NOINLINE mkExplicit #-}
  
  {-------------------------------------------------------------------------------
    Internal: manipulating the callstack
  -------------------------------------------------------------------------------}
  
  mapCallSites ::
       ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
    -> CallStack -> CallStack
  mapCallSites f = fromCallSiteList . f . getCallStack
  