module Control.Monad.CC.CCRef (
CC,
SubCont,
Prompt,
newPrompt,
pushPrompt,
takeSubCont,
pushSubCont,
runCC,
abortP,
pushDelimSubCont,
shiftP,
shift0P,
controlP,
isPromptSet,
module Control.Monad.Ref
) where
import Control.Monad (liftM2)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Ref
import Control.Monad.ST
newtype CC m a = CC{unCC:: (a -> m ()) -> PTop m -> m ()}
data Prompt m a = Prompt{mbox :: Ref m (CC m a),
mark :: Mark m}
data PFrame m = PFrame{pfr_mark :: Mark m,
pfr_ek :: EK m}
type PStack m = [PFrame m]
type PTop m = Ref m (PStack m)
data SubCont m a b = SubCont{subcont_pa :: Prompt m a,
subcont_pb :: Prompt m b,
subcont_ps :: [PFrame m]}
type DelimCCE = ()
type EK m = m ()
type Ekfragment = ()
instance Monad m => Monad (CC m) where
return x = CC $ \k _ -> k x
m >>= f = CC $ \k ptop -> unCC m (\v -> unCC (f v) k ptop) ptop
instance MonadTrans CC where
lift m = CC $ \k _ -> m >>= k
instance MonadIO m => MonadIO (CC m) where
liftIO = lift . liftIO
instance (Monad m, MonadRef m)
=> MonadRef (CC m) where
type Ref (CC m) = Ref m
newRef = lift . newRef
readRef = lift . readRef
writeRef = (lift .) . writeRef
modifyRef = (lift .) . modifyRef
instance (Monad m, MonadAtomicRef m)
=> MonadAtomicRef (CC m) where
atomicModifyRef = (lift .) . atomicModifyRef
runCC :: (Monad m, MonadRef m) => CC m a -> m a
runCC m = do
ptop <- newRef []
ans <- newRef (error "runCC: no prompt was ever set!")
unCC m (writeRef ans) ptop
readRef ans
type Mark m = Ref m Bool
new_mark :: MonadRef m => m (Mark m)
new_mark = newRef False
with_marked_mark :: (Monad m, MonadRef m) => Mark m -> m a -> m a
with_marked_mark mark body = do
writeRef mark True
r <- body
writeRef mark False
return r
is_marked :: MonadRef m => Mark m -> m Bool
is_marked = readRef
mbox_empty :: CC m a
mbox_empty = error "Empty mbox"
mbox_receive :: (Monad m, MonadRef m) => Prompt m a -> CC m a
mbox_receive p = do
k <- readRef (mbox p)
writeRef (mbox p) mbox_empty
k
push_pframe :: (Monad m, MonadRef m) => PTop m -> PFrame m -> m ()
push_pframe ptop fr = do
stack <- readRef ptop
writeRef ptop (fr:stack)
pop_pframe :: (Monad m, MonadRef m) => PTop m -> m (PFrame m)
pop_pframe ptop = readRef ptop >>= check
where check [] = error "Empty PStack! Can't be happening"
check (h:t) = writeRef ptop t >> return h
get_pstack :: (Monad m, MonadRef m) => CC m (PStack m)
get_pstack = CC $ \k ptop -> readRef ptop >>= k
unwind :: (Monad m, MonadRef m) =>
[PFrame m] -> Mark m -> PStack m ->
m (PFrame m, PStack m, [PFrame m])
unwind acc mark stack = with_marked_mark mark (loop acc stack)
where
loop acc [] = error "No prompt was set"
loop acc s@(h:t) = do
marked <- is_marked (pfr_mark h)
if marked then return (h,s,acc) else loop (h:acc) t
unwind_abort :: (Monad m, MonadRef m) =>
Mark m -> PStack m -> m (PFrame m, PStack m)
unwind_abort mark stack = with_marked_mark mark (loop stack)
where
loop [] = error "No prompt was set"
loop s@(h:t) = do
marked <- is_marked (pfr_mark h)
if marked then return (h,s) else loop t
rev_append :: [a] -> [a] -> [a]
rev_append [] l2 = l2
rev_append (h:t) l2 = rev_append t (h:l2)
newPrompt :: (Monad m, MonadRef m) => CC m (Prompt m a)
newPrompt = lift $ liftM2 Prompt (newRef mbox_empty) new_mark
popPrompt :: (Monad m, MonadRef m) =>
Prompt m w -> CC m w
popPrompt p = CC $ \k ptop -> do
h <- pop_pframe ptop
unCC (mbox_receive p) k ptop
pushPrompt :: (Monad m, MonadRef m) =>
Prompt m w -> CC m w -> CC m w
pushPrompt p body = CC $ \k ptop -> do
let ek = unCC (popPrompt p) k ptop
let raise = do
(h:_) <- readRef ptop
pfr_ek h
push_pframe ptop (PFrame (mark p) ek)
unCC body (\res -> writeRef (mbox p) (return res) >> raise) ptop
takeSubCont :: (Monad m, MonadRef m) =>
Prompt m b -> (SubCont m a b -> CC m b) -> CC m a
takeSubCont p f = newPrompt >>= \pa -> CC $ \k ptop -> do
let ek = unCC (popPrompt pa) k ptop
stack <- readRef ptop
(h,s,subcontchain) <- unwind [] (mark p) (PFrame (mark pa) ek:stack)
writeRef ptop s
writeRef (mbox p) (f (SubCont pa p subcontchain))
pfr_ek h
pushSubCont :: (Monad m, MonadRef m) =>
SubCont m a b -> CC m a -> CC m b
pushSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do
let ek = unCC (popPrompt pb) k ptop
ephemeral <- new_mark
stack <- readRef ptop
let stack'@(h:_) = rev_append subcontchain (PFrame ephemeral ek:stack)
writeRef ptop stack'
writeRef (mbox pa) m
pfr_ek h
pushDelimSubCont :: (Monad m, MonadRef m) =>
SubCont m a b -> CC m a -> CC m b
pushDelimSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do
let ek = unCC (popPrompt pb) k ptop
stack <- readRef ptop
let stack'@(h:_) = rev_append subcontchain (PFrame (mark pb) ek:stack)
writeRef ptop stack'
writeRef (mbox pa) m
pfr_ek h
abortP :: (Monad m, MonadRef m) =>
Prompt m w -> CC m w -> CC m any
abortP p res = CC $ \k ptop -> do
stack <- readRef ptop
(h,s) <- unwind_abort (mark p) stack
writeRef ptop s
writeRef (mbox p) res
pfr_ek h
isPromptSet :: (Monad m, MonadRef m) =>
Prompt m w -> CC m Bool
isPromptSet p = do
stack <- get_pstack
with_marked_mark (mark p) (loop stack)
where
loop [] = return False
loop s@(h:t) = do
marked <- is_marked (pfr_mark h)
if marked then return True else loop t
shiftP :: (Monad m, MonadRef m) =>
Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a
shiftP p f = takeSubCont p $ \sk ->
pushPrompt p (f (\c ->
pushDelimSubCont sk (return c)))
shift0P :: (Monad m, MonadRef m) =>
Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a
shift0P p f = takeSubCont p $ \sk ->
f (\c ->
pushDelimSubCont sk (return c))
controlP :: (Monad m, MonadRef m) =>
Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a
controlP p f = takeSubCont p $ \sk ->
pushPrompt p (f (\c ->
pushSubCont sk (return c)))
expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)
else error $ "expected " ++ (show ve) ++
", computed " ++ (show vp)
assure :: Monad m => CC m Bool -> CC m ()
assure m = do
v <- m
if v then return () else error "assertion failed"
test0 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5
test1 = (expect 1 =<<) . runCC $ do
p <- newPrompt
assure (isPromptSet p >>= return . not)
pushPrompt p $ (assure (isPromptSet p) >> return 1)
incr :: Monad m => Int -> m Int -> m Int
incr n m = m >>= return . (n +)
test2 = (expect 9 =<<) . runCC $ do
p <- newPrompt
incr 4 . pushPrompt p $ pushPrompt p (return 5)
test3 = (expect 9 =<<) . runCC $ do
p <- newPrompt
incr 4 . pushPrompt p $ (incr 6 $ abortP p (return 5))
test3' = (expect 9 =<<) . runCC $ do
p <- newPrompt
incr 4 . pushPrompt p . pushPrompt p $ (incr 6 $ abortP p (return 5))
test3'1 = (expect 9 =<<) . runCC $ do
p <- newPrompt
incr 4 . pushPrompt p . pushPrompt p $
(incr 6 $ takeSubCont p (\_ -> (return 5)))
test3'' = (expect 27 =<<) . runCC $ do
p <- newPrompt
incr 20 . pushPrompt p $
do
v1 <- pushPrompt p (incr 6 $ abortP p (return 5))
v2 <- abortP p (return 7)
return $ v1 + v2 + 10
test3''1 = (expect 27 =<<) . runCC $ do
p <- newPrompt
incr 20 . pushPrompt p $
do
v1 <- pushPrompt p (incr 6 $ takeSubCont p (\_ -> return 5))
v2 <- takeSubCont p (\_ -> return 7)
return $ v1 + v2 + 10
test3''' = (print =<<) . runCC $ do
p <- newPrompt
v <- pushPrompt p $
do
v1 <- pushPrompt p (incr 6 $ abortP p (return 5))
v2 <- abortP p (return 7)
return $ v1 + v2 + 10
assure (isPromptSet p >>= return . not)
v <- abortP p (return 9)
assure (return False)
return $ v + 20
test4 = (expect 35 =<<) . runCC $ do
p <- newPrompt
incr 20 . pushPrompt p $
incr 10 . takeSubCont p $ \sk ->
pushPrompt p (pushSubCont sk (return 5))
test41 = (expect 35 =<<) . runCC $ do
p <- newPrompt
incr 20 . pushPrompt p $
incr 10 . takeSubCont p $ \sk ->
pushSubCont sk (pushPrompt p (pushSubCont sk (abortP p (return 5))))
test5 = (expect 117 =<<) . runCC $ do
p <- newPrompt
incr 10 . pushPrompt p $
incr 2 . shiftP p $ \sk -> incr 100 $ sk =<< (sk 3)
test5'' = (expect 115 =<<) . runCC $ do
p0 <- newPrompt
p1 <- newPrompt
incr 10 . pushPrompt p0 $
incr 2 . shiftP p0 $ \sk ->
incr 100 $ sk =<<
(pushPrompt p1 (incr 9 $ sk =<< (abortP p1 (return 3))))
test5''' = (expect 115 =<<) . runCC $ do
p0 <- newPrompt
p1 <- newPrompt
incr 10 . pushPrompt p0 $
incr 2 . (id =<<) . shiftP p0 $ \sk ->
incr 100 $ sk
(pushPrompt p1 (incr 9 $ sk (abortP p1 (return 3))))
test54 = (expect 124 =<<) . runCC $ do
p0 <- newPrompt
p1 <- newPrompt
incr 10 . pushPrompt p0 $
incr 2 . (id =<<) . shiftP p0 $ \sk ->
incr 100 $ sk
(pushPrompt p1 (incr 9 $ sk (abortP p0 (return 3))))
test6 = (expect 15 =<<) . runCC $ do
p1 <- newPrompt
p2 <- newPrompt
let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3))
incr 10 . pushPrompt p1 $
incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice
test7 = (expect 135 =<<) . runCC $ do
p1 <- newPrompt
p2 <- newPrompt
p3 <- newPrompt
let pushtwice sk = pushSubCont sk (pushSubCont sk
(takeSubCont p2
(\sk2 -> pushSubCont sk2
(pushSubCont sk2 (return 3)))))
incr 100 . pushPrompt p1 $
incr 1 . pushPrompt p2 $
incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)
test7' = (expect 135 =<<) . runCC $ do
p1 <- newPrompt
p2 <- newPrompt
p3 <- newPrompt
let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))
incr 100 . pushPrompt p1 $
incr 1 . pushPrompt p2 $
incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)
test7'' = (expect 135 =<<) . runCC $ do
p1 <- newPrompt
p2 <- newPrompt
p3 <- newPrompt
let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))
incr 100 . pushPrompt p1 $
incr 1 . pushPrompt p2 $
incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)
test7st = runST (runCC $ do
p1 <- newPrompt
p2 <- newPrompt
p3 <- newPrompt
let pushtwice sk = pushSubCont sk (pushSubCont sk
(takeSubCont p2
(\sk2 -> pushSubCont sk2
(pushSubCont sk2 (return 3)))))
incr 100 . pushPrompt p1 $
incr 1 . pushPrompt p2 $
incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice))
test7st_check = return test7st >>= expect 135
testls = (expect ["a"] =<<) . runCC $ do
p <- newPrompt
pushPrompt p (
do
let x = shiftP p (\f -> f [] >>= (return . ("a":)))
xv <- x
shiftP p (\_ -> return xv))
testls0 = (expect [] =<<) . runCC $ do
p <- newPrompt
pushPrompt p (
(return . ("a":)) =<<
(pushPrompt p (shift0P p (\_ -> (shift0P p (\_ -> return []))))))
testls01 = (expect ["a"] =<<) . runCC $ do
p <- newPrompt
pushPrompt p (
(return . ("a":)) =<<
(pushPrompt p
(shift0P p (\f -> f (shift0P p (\_ -> return []))) >>= id)))
testlc = (expect [] =<<) . runCC $ do
p <- newPrompt
pushPrompt p (
do
let x = controlP p (\f -> f [] >>= (return . ("a":)))
xv <- x
controlP p (\_ -> return xv))
testlc' = (expect ["a"] =<<) . runCC $ do
p <- newPrompt
pushPrompt p (
do
let x = controlP p (\f -> f [] >>= (return . ("a":)))
xv <- x
controlP p (\g -> g xv))
testlc1 = (expect 2 =<<) . runCC $ do
p <- newPrompt
pushPrompt p (do
takeSubCont p (\sk ->
pushPrompt p (pushSubCont sk (return 1)))
takeSubCont p (\sk -> pushSubCont sk (return 2)))
type DelimControl m a b =
Prompt m b -> ((a -> CC m b) -> CC m b) -> CC m a
traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()
traverse op lst = (print =<<) . runCC $ do
p <- newPrompt
let visit [] = return []
visit (h:t) = do
v <- op p (\f -> f t >>= (return . (h:)))
visit v
pushPrompt p (visit lst)
doall = sequence_ [test0, test1, test2, test3, test3', test3'1,
test3'', test3''1,
test4, test41, test5, test5'', test5''', test54,
test6, test7, test7', test7'', test7st_check,
testls, testls0, testls01, testlc, testlc', testlc1
]