{-# 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 :: forall a (m :: * -> *) b.
HasCallStack =>
(HasCallStack => a -> m b) -> Callback m a b
callback HasCallStack => a -> m b
callbackFn = Callback_ CallStack m a b -> Callback m a b
forall (m :: * -> *) a b.
Callback_ CallStack m a b -> Callback m a b
Wrap (CallSite -> (HasCallStack => a -> m b) -> Callback_ CallStack m a b
forall cs (m :: * -> *) a b.
CallSite -> ((?callStack::cs) => a -> m b) -> Callback_ cs m a b
callback_ CallSite
HasCallStack => CallSite
callSite a -> m b
HasCallStack => a -> m b
callbackFn)

-- | Invoke 'Callback'
invokeCallback :: HasCallStack => Callback m a b -> a -> m b
invokeCallback :: forall (m :: * -> *) a b.
HasCallStack =>
Callback m a b -> a -> m b
invokeCallback (Wrap Callback_ CallStack m a b
cb) a
a =
    CallStack -> a -> m b
callbackFunction (CallStack -> CallStack
aux CallStack
HasCallStack => CallStack
callStack) a
a
  where
    Callback_{CallStack -> a -> m b
callbackFunction :: CallStack -> a -> m b
callbackFunction :: forall cs (m :: * -> *) a b. Callback_ cs m a b -> cs -> a -> m b
callbackFunction, CallSite
callbackDefSite :: CallSite
callbackDefSite :: forall cs (m :: * -> *) a b. Callback_ cs m a b -> CallSite
callbackDefSite} = Callback_ CallStack m a b
cb

    aux :: CallStack -> CallStack
    aux :: CallStack -> CallStack
aux = ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
-> CallStack -> CallStack
mapCallSites (([([Char], SrcLoc)] -> [([Char], SrcLoc)])
 -> CallStack -> CallStack)
-> ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
-> CallStack
-> CallStack
forall a b. (a -> b) -> a -> b
$ \[([Char], SrcLoc)]
cs ->
        case [([Char], SrcLoc)]
cs of
          ([Char]
_, SrcLoc
loc):[([Char], SrcLoc)]
cs' -> -- this is the call to invokeCallback
              ( [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                    [Char]
"invoking callback defined at "
                    -- callee is 'callback', no point showing that
                  , [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"{unknown}" (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
                      CallSite -> Maybe [Char]
callSiteCaller CallSite
callbackDefSite
                  , [Char] -> (SrcLoc -> [Char]) -> Maybe SrcLoc -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\SrcLoc
l -> [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcLoc -> [Char]
briefSrcLoc SrcLoc
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")") (Maybe SrcLoc -> [Char]) -> Maybe SrcLoc -> [Char]
forall a b. (a -> b) -> a -> b
$
                      CallSite -> Maybe SrcLoc
callSiteSrcLoc CallSite
callbackDefSite

                  ]
                --      "invoking callback defined at "
                -- ++ prettyCallSite callbackDefSite
              , SrcLoc
loc
              )
            ([Char], SrcLoc) -> [([Char], SrcLoc)] -> [([Char], SrcLoc)]
forall a. a -> [a] -> [a]
: [([Char], SrcLoc)]
cs'
          [] ->
            [Char] -> [([Char], SrcLoc)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [([Char], SrcLoc)]) -> [Char] -> [([Char], SrcLoc)]
forall a b. (a -> b) -> a -> b
$ [Char]
"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_ {
      forall cs (m :: * -> *) a b. Callback_ cs m a b -> cs -> a -> m b
callbackFunction :: !(cs -> a -> m b)
    , forall cs (m :: * -> *) a b. Callback_ cs m a b -> CallSite
callbackDefSite  :: !CallSite
    }

callback_ :: forall cs m a b.
     CallSite
  -> ((?callStack :: cs) => a -> m b)
  -> Callback_ cs m a b
callback_ :: forall cs (m :: * -> *) a b.
CallSite -> ((?callStack::cs) => a -> m b) -> Callback_ cs m a b
callback_ CallSite
defSite (?callStack::cs) => a -> m b
f = (cs -> a -> m b) -> CallSite -> Callback_ cs m a b
forall cs (m :: * -> *) a b.
(cs -> a -> m b) -> CallSite -> Callback_ cs m a b
Callback_ (((?callStack::cs) => a -> m b) -> cs -> a -> m b
forall cs a. ((?callStack::cs) => a) -> cs -> a
mkExplicit a -> m b
(?callStack::cs) => a -> m b
f) CallSite
defSite

mkExplicit :: ((?callStack :: cs) => a) -> (cs -> a)
mkExplicit :: forall cs a. ((?callStack::cs) => a) -> cs -> a
mkExplicit (?callStack::cs) => a
f cs
cs = let ?callStack = cs
?callStack::cs
cs in a
(?callStack::cs) => a
f

{-# NOINLINE callback_  #-}
{-# NOINLINE mkExplicit #-}

{-------------------------------------------------------------------------------
  Internal: manipulating the callstack
-------------------------------------------------------------------------------}

mapCallSites ::
     ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
  -> CallStack -> CallStack
mapCallSites :: ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
-> CallStack -> CallStack
mapCallSites [([Char], SrcLoc)] -> [([Char], SrcLoc)]
f = [([Char], SrcLoc)] -> CallStack
fromCallSiteList ([([Char], SrcLoc)] -> CallStack)
-> (CallStack -> [([Char], SrcLoc)]) -> CallStack -> CallStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], SrcLoc)] -> [([Char], SrcLoc)]
f ([([Char], SrcLoc)] -> [([Char], SrcLoc)])
-> (CallStack -> [([Char], SrcLoc)])
-> CallStack
-> [([Char], SrcLoc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [([Char], SrcLoc)]
getCallStack