module Control.Monad.MultiPass.Instrument.TopKnot
( TopKnot
, load, store
)
where
import Control.Exception ( assert )
import Control.Monad.ST2
import Control.Monad.MultiPass
import Data.Maybe ( isNothing, isJust, fromJust )
data TopKnot a r w p1 p2 tc
= TopKnot
{ loadInternal :: MultiPassPrologue r w tc (p2 a)
, storeInternal :: (p1 a) -> MultiPassEpilogue r w tc ()
}
load :: TopKnot a r w p1 p2 tc -> MultiPassPrologue r w tc (p2 a)
load =
loadInternal
store :: TopKnot a r w p1 p2 tc -> p1 a -> MultiPassEpilogue r w tc ()
store =
storeInternal
newtype GC r w a
= GC (ST2Ref r w (Maybe a))
instance Instrument tc () () (TopKnot a r w Off Off tc) where
createInstrument _ _ () =
wrapInstrument $ TopKnot
{ loadInternal = return Off
, storeInternal = \Off -> return ()
}
instance Instrument tc () (GC r w a) (TopKnot a r w On Off tc) where
createInstrument st2ToMP _ (GC r) =
wrapInstrument $ TopKnot
{ loadInternal = return Off
, storeInternal = \(On x) ->
mkMultiPassEpilogue $ st2ToMP $
do mx <- readST2Ref r
assert (isNothing mx) $ return ()
writeST2Ref r (Just x)
}
instance Instrument tc () (GC r w a) (TopKnot a r w On On tc) where
createInstrument st2ToMP _ (GC r) =
wrapInstrument $ TopKnot
{ loadInternal =
mkMultiPassPrologue $ st2ToMP $
do mx <- readST2Ref r
assert (isJust mx) $ return ()
return $ On $ fromJust mx
, storeInternal = \(On x) ->
mkMultiPassEpilogue $ st2ToMP $
do mx <- readST2Ref r
assert (isNothing mx) $ return ()
writeST2Ref r (Just x)
}
instance BackTrack r w tc (GC r w a)
instance NextGlobalContext r w () () (GC r w a) where
nextGlobalContext _ _ () () =
do mx <- newST2Ref Nothing
return (GC mx)
instance NextGlobalContext r w () (GC r w a) (GC r w a) where
nextGlobalContext _ _ () gc = return gc