module Control.Monad.MultiPass.Instrument.Monoid2
( Monoid2
, tell, listen
, tellPrologue, listenEpilogue
)
where
import Control.Monad ( void )
import Control.Monad.MultiPass
import Control.Monad.MultiPass.ThreadContext.MonoidTC
import Data.Monoid
data Monoid2 a r w p1 p2 tc
= Monoid2
{ tellInternal :: !(p1 a -> MultiPassBase r w tc ())
, listenInternal :: !(MultiPass r w tc (p2 a))
, listenInternalEpilogue :: !(MultiPassEpilogue r w tc (p1 a))
}
tell
:: (Monoid a, Monad p1, Monad p2)
=> Monoid2 a r w p1 p2 tc
-> p1 a
-> MultiPass r w tc ()
tell m v =
mkMultiPass $ tellInternal m v
tellPrologue
:: (Monoid a, Monad p1, Monad p2)
=> Monoid2 a r w p1 p2 tc
-> p1 a
-> MultiPassPrologue r w tc ()
tellPrologue m v =
mkMultiPassPrologue $ tellInternal m v
listen
:: (Monoid a, Monad p1, Monad p2)
=> Monoid2 a r w p1 p2 tc
-> MultiPass r w tc (p2 a)
listen =
listenInternal
listenEpilogue
:: (Monoid a, Monad p1, Monad p2)
=> Monoid2 a r w p1 p2 tc
-> MultiPassEpilogue r w tc (p1 a)
listenEpilogue =
listenInternalEpilogue
newtype GC a
= GC a
instance Instrument tc () () (Monoid2 a r w Off Off tc) where
createInstrument _ _ () =
wrapInstrument $
Monoid2
{ tellInternal = \Off -> return ()
, listenInternal = return Off
, listenInternalEpilogue = return Off
}
instance Monoid a =>
Instrument tc (MonoidTC a) ()
(Monoid2 a r w On Off tc) where
createInstrument _ updateCtx () =
wrapInstrument $
Monoid2
{ tellInternal = \(On x) ->
void $ updateCtx (MonoidTC . mappend x . unwrapMonoidTC)
, listenInternal =
return Off
, listenInternalEpilogue =
mkMultiPassEpilogue $
do MonoidTC x <- updateCtx id
return (On x)
}
instance Instrument tc () (GC a) (Monoid2 a r w On On tc) where
createInstrument _ _ (GC x) =
wrapInstrument $ Monoid2
{ tellInternal = \(On _) -> return ()
, listenInternal = return $ On $ x
, listenInternalEpilogue = return $ On $ x
}
instance BackTrack r w () (GC a)
instance NextGlobalContext r w (MonoidTC a) () (GC a) where
nextGlobalContext _ _ (MonoidTC x) () =
return (GC x)
instance NextGlobalContext r w () (GC a) (GC a) where
nextGlobalContext _ _ () gc =
return gc