module Control.Monad.MultiPass.Instrument.Knot3
( Knot3
, knot3
)
where
import Control.Monad ( void )
import Control.Monad.ST2
import Control.Monad.MultiPass
import Control.Monad.MultiPass.ThreadContext.CounterTC
data Knot3 (a :: *) r w (p1 :: * -> *) p2 p3 tc
= Knot3
{ knot3Internal :: !(forall b.
(p3 a -> MultiPass r w tc (p2 a, b)) -> MultiPass r w tc b)
}
knot3
:: (Monad p1, Monad p2, Monad p3)
=> Knot3 a r w p1 p2 p3 tc
-> (p3 a -> MultiPass r w tc (p2 a, b))
-> MultiPass r w tc b
knot3 =
knot3Internal
newtype Buffer r w a
= Buffer (ST2Array r w Int a)
instance Instrument tc () () (Knot3 a r w Off Off Off tc) where
createInstrument _ _ () =
wrapInstrument $ Knot3 $ \f ->
do (Off, x) <- f Off
return x
instance Instrument tc (CounterTC1 Int r) ()
(Knot3 a r w On Off Off tc) where
createInstrument _ updateCtx () =
wrapInstrument $ Knot3 $ \f ->
do void $ mkMultiPass $ updateCtx incrCounterTC1
(Off, x) <- f Off
return x
instance Instrument tc (CounterTC2 Int r) (Buffer r w a)
(Knot3 a r w On On Off tc) where
createInstrument st2ToMP updateCtx (Buffer xs) =
wrapInstrument $ Knot3 $ \f ->
do counter <- mkMultiPass $ updateCtx incrCounterTC2
let k = counterVal2 counter
(On v, x) <- f Off
mkMultiPass $ st2ToMP $ writeST2Array xs k v
return x
instance Instrument tc (CounterTC2 Int r) (Buffer r w a)
(Knot3 a r w On On On tc) where
createInstrument st2ToMP updateCtx (Buffer xs) =
wrapInstrument $ Knot3 $ \f ->
do counter <- mkMultiPass $ updateCtx incrCounterTC2
let k = counterVal2 counter
v <- mkMultiPass $ st2ToMP $ readST2Array xs k
(_,x) <- f (On v)
return x
instance BackTrack r w tc (Buffer r w a)
instance NextGlobalContext r w (CounterTC1 Int r)
() (Buffer r w a) where
nextGlobalContext _ _ counter () =
let n = counterVal1 counter in
do xs <- newST2Array_ (0, n1)
return (Buffer xs)
instance NextGlobalContext r w tc (Buffer r w a)
(Buffer r w a) where
nextGlobalContext _ _ _ (Buffer xs) = return (Buffer xs)