module HERMIT.Dictionary.Debug
(
externals
, bracketR
, observeR
, observeFailureR
, traceR
) where
import Control.Arrow
import HERMIT.Context
import HERMIT.Core
import HERMIT.External
import HERMIT.Kure
import HERMIT.Monad
externals :: [External]
externals = map (.+ Debug)
[ external "trace" (traceR :: String -> RewriteH LCoreTC)
[ "give a side-effect message as output when processing this command" ]
, external "observe" (observeR :: String -> RewriteH LCoreTC)
[ "give a side-effect message as output, and observe the value being processed" ]
, external "observe-failure" (observeFailureR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC)
[ "give a side-effect message if the rewrite fails, including the failing input" ]
, external "bracket" (bracketR :: String -> RewriteH LCoreTC -> RewriteH LCoreTC)
[ "if given rewrite succeeds, see its input and output" ]
]
observeFailureR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)
=> String -> Rewrite c m a -> Rewrite c m a
observeFailureR str m = m <+ observeR str
observeR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, Monad m)
=> String -> Rewrite c m a
observeR msg = extractR $ sideEffectR $ \ cxt -> sendDebugMessage . DebugCore msg cxt
traceR :: (HasDebugChan m, Monad m) => String -> Rewrite c m a
traceR msg = sideEffectR $ \ _ _ -> sendDebugMessage $ DebugTick msg
bracketR :: (Injection a LCoreTC, ReadBindings c, ReadPath c Crumb, HasDebugChan m, MonadCatch m)
=> String -> Rewrite c m a -> Rewrite c m a
bracketR msg rr = do
(e,r) <- idR &&& attemptM rr
either fail (\ e' -> do _ <- return e >>> observeR before
return e' >>> observeR after) r
where before = msg ++ " (before)"
after = msg ++ " (after)"