CC-delcont-alt 0.1.0.0 → 0.1.1.0
raw patch · 7 files changed
+608/−263 lines, 7 filesdep +CC-delcont-altdep +test-frameworkdep +test-framework-doctest
Dependencies added: CC-delcont-alt, test-framework, test-framework-doctest
Files
- CC-delcont-alt.cabal +14/−10
- CC_Test.hs +0/−239
- CC_Test1.hs +270/−0
- CC_Test2.hs +269/−0
- DocTest.hs +17/−0
- Generator1.hs +14/−5
- Generator2.hs +24/−9
CC-delcont-alt.cabal view
@@ -1,5 +1,5 @@ name: CC-delcont-alt -version: 0.1.0.0 +version: 0.1.1.0 author: Oleg Kiselyov maintainer: shelarcy <shelarcy@gmail.com> license: BSD3 @@ -21,17 +21,21 @@ This package split multi-prompt delimited control from <http://hackage.haskell.org/package/liboleg> for usability. stability: experimental -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple extra-source-files: - Bench_nondet.hs - CC_Test.hs + Bench_nondet.hs, CC_Test1.hs, CC_Test2.hs Generator1.hs, Generator2.hs, ProtocolRecovery.hs library - build-depends: base >= 3 && < 5, mtl, - CC-delcont-ref, CC-delcont-exc, CC-delcont-cxe - exposed-modules: - other-modules: - cc-options: - ld-options: + build-depends: base >= 3 && < 5, mtl, + CC-delcont-ref, CC-delcont-exc, CC-delcont-cxe + default-language: Haskell2010 + +Test-Suite DocTest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + default-language: Haskell2010 + build-depends: base >= 3 && < 5, mtl, + CC-delcont-alt, + test-framework, test-framework-doctest
− CC_Test.hs
@@ -1,239 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- Tests of the CC Transformer operations: CCExe--module CC_testsT where--import Control.Monad.CC.CCCxe--- import Control.Monad.CC.CCExc-import Control.Monad.Trans-import Data.Typeable--expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)- else error $ "expected " ++ (show ve) ++- ", computed " ++ (show vp)--test1 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5--- 5--doall = sequence_ [test1, test2, test3, test3', test3'', - test4, test5, test41, test5''1, test5''21, test5''22,- test5''3, test54,- test6, test7, test7', test7'',- testls, testls0, testls01, testlc, testlc', testlc1- ]--- test3''' should raise an error--incr :: Monad m => Int -> m Int -> m Int-incr n m = m >>= return . (n +)--test2 = (expect 9 =<<) . runCC $- incr 4 . pushPrompt ps $ pushPrompt ps (return 5)--- 9--test3 = (expect 9 =<<) . runCC $- incr 4 . pushPrompt ps $ (incr 6 $ abortP ps (return 5))--test3' = (expect 9 =<<) . runCC $- incr 4 . pushPrompt ps . pushPrompt ps $ (incr 6 $ abortP ps (return 5))--test3'' = (expect 27 =<<) . runCC $- incr 20 . pushPrompt ps $ - do- v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))- v2 <- abortP ps (return 7)- return $ v1 + v2 + 10--test3''' = (print =<<) . runCC $ do- v <- pushPrompt ps $ - do- v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))- v2 <- abortP ps (return 7)- return $ v1 + v2 + 10- v <- abortP ps (return 9)- return $ v + 20--- error--test4 = (expect 35 =<<) . runCC $- incr 20 . pushPrompt ps $- incr 10 . takeSubCont ps $ \sk -> - pushPrompt ps (pushSubCont sk (return 5))--test41 = (expect 35 =<<) . runCC $ - incr 20 . pushPrompt ps $ - incr 10 . takeSubCont ps $ \sk -> - pushSubCont sk (pushPrompt ps (pushSubCont sk (abortP ps (return 5))))----- Danvy/Filinski's test---(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))---; --> 117--test5 = (expect 117 =<<) . runCC $- incr 10 . pushPrompt ps $- incr 2 . shiftP ps $ \sk -> incr 100 $ sk =<< (sk 3)--- 117---- multi-prompt tests---- Testing prompt flavor P2--test5''1 = (expect 115 =<<) . runCC $- incr 10 . pushPrompt p2L $ - incr 2 . (id =<<) . shiftP p2L $ \sk -> - incr 100 $ (sk (pushPrompt p2R- (sk (sk (abortP p2R (return 3))))))---- Testing prompt flavor PP---- Here, p1 and p0 have the same type, and so p0 is actually the same as p1-test5''21 = (expect 117 =<<) . runCC $- incr 10 . pushPrompt p0 $ - incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ (sk (pushPrompt p1- (sk (sk (abortP p1 (return 3))))))- where p0 = pp `as_prompt_type` (0::Int)- p1 = pp---- Now, p1 and p0 have different types-newtype NInt = NInt{unNInt :: Int} deriving Typeable-test5''22 = (expect 115 =<<) . runCC $- incr 10 . pushPrompt p0 $ - incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ (sk (lunNInt (pushPrompt p1- (lNInt - (sk (sk (abortP p1 (return (NInt 3)))))))))- where p0 = pp `as_prompt_type` (0::Int)- p1 = pp- lunNInt m = m >>= return . unNInt- lNInt m = m >>= return . NInt---- Testing prompt flavor PD--- p0 and p1 have the same type, but are different-test5''3 = (expect 115 =<<) . runCC $- incr 10 . pushPrompt p0 $ - incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ (sk (pushPrompt p1- (sk (sk (abortP p1 (return 3))))))- where p0 = newPrompt 0 `as_prompt_type` (0::Int)- p1 = newPrompt 1--test54 = (expect 117 =<<) . runCC $- incr 10 . pushPrompt p0 $ - incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ (sk (pushPrompt p1- (sk (sk (abortP p0 (return 3))))))- where p0 = newPrompt 0 `as_prompt_type` (0::Int)- p1 = newPrompt 1--test6 = (expect 15 =<<) . runCC $- let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3)) in- incr 10 . pushPrompt p1 $ - incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice- where p1 = newPrompt 1 `as_prompt_type` (0::Int)- p2 = newPrompt 2----- The most difficult test. The difference between the prompts really matters--- now-test7 = (expect 135 =<<) . runCC $- let pushtwice sk = pushSubCont sk (pushSubCont sk - (takeSubCont p2- (\sk2 -> pushSubCont sk2- (pushSubCont sk2 (return 3)))))- in- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)- where p1 = newPrompt 1 `as_prompt_type` (0::Int)- p2 = newPrompt 2- p3 = newPrompt 3--- 135--test7' = (expect 135 =<<) . runCC $- let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))- in- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)- where p1 = newPrompt 1 `as_prompt_type` (0::Int)- p2 = newPrompt 2- p3 = newPrompt 3--- 135--test7'' = (expect 135 =<<) . runCC $- let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))- in- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)- where p1 = newPrompt 1 `as_prompt_type` (0::Int)- p2 = newPrompt 2- p3 = newPrompt 3----- Checking shift, shift0, control --testls = (expect ["a"] =<<) . runCC $- pushPrompt ps (- do- let x = shiftP ps (\f -> f [] >>= (return . ("a":)))- xv <- x- shiftP ps (\_ -> return xv))----- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))-testls0 = (expect [] =<<) . runCC $- pushPrompt ps (- (return . ("a":)) =<< - (pushPrompt ps (shift0P ps (\_ -> (shift0P ps (\_ -> return []))))))- -testls01 = (expect ["a"] =<<) . runCC $- pushPrompt ps (- (return . ("a":)) =<< - (pushPrompt ps - (shift0P ps (\f -> f (shift0P ps (\_ -> return []))) >>= id)))- --testlc = (expect [] =<<) . runCC $- pushPrompt ps (- do- let x = controlP ps (\f -> f [] >>= (return . ("a":)))- xv <- x- controlP ps (\_ -> return xv))- --testlc' = (expect ["a"] =<<) . runCC $- pushPrompt ps (- do- let x = controlP ps (\f -> f [] >>= (return . ("a":)))- xv <- x- controlP ps (\g -> g xv))--- ["a"]--testlc1 = (expect 2 =<<) . runCC $- pushPrompt ps (do- takeSubCont ps (\sk -> - pushPrompt ps (pushSubCont sk (return 1)))- takeSubCont ps (\sk -> pushSubCont sk (return 2)))----- traversing puzzle by Olivier Danvy--type DelimControl m a b = - Prompt (PS b) m b -> - ((a -> CC (PS b) m b) -> CC (PS b) m b) -> CC (PS b) m a--traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()-traverse op lst = (print =<<) . runCC $- let visit [] = return []- visit (h:t) = do- v <- op ps (\f -> f t >>= (return . (h:)))- visit v- in pushPrompt ps (visit lst)----- *CC_Refn> traverse shiftP [1,2,3,4,5]--- [1,2,3,4,5]--- *CC_Refn> traverse controlP [1,2,3,4,5]--- [5,4,3,2,1]
+ CC_Test1.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Tests of the CC Transformer operations: CCExe++module CC_testsT where++import Control.Monad.CC.CCCxe+-- import Control.Monad.CC.CCExc+import Control.Monad.Trans+import Data.Typeable++expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)+ else error $ "expected " ++ (show ve) +++ ", computed " ++ (show vp)++test1 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5+-- 5++doall = sequence_ [test1, test2, test3, test3', test3'', + test4, test5, test41, test5''1, test5''21, test5''22,+ test5''3, test54,+ test6, test7, test7', test7'',+ testls, testls0, testls01, testlc, testlc', testlc1+ ]++-- | Do all tests+--+-- >>> doall+-- expected answer 5+-- expected answer 9+-- expected answer 9+-- expected answer 9+-- expected answer 27+-- expected answer 35+-- expected answer 117+-- expected answer 35+-- expected answer 115+-- expected answer 117+-- expected answer 115+-- expected answer 115+-- expected answer 117+-- expected answer 15+-- expected answer 135+-- expected answer 135+-- expected answer 135+-- expected answer ["a"]+-- expected answer []+-- expected answer ["a"]+-- expected answer []+-- expected answer ["a"]+-- expected answer 2++-- | test3''' should raise an error+--+-- >>> test3'''+-- *** Exception: Escaping bubble: you have forgotten pushPrompt++incr :: Monad m => Int -> m Int -> m Int+incr n m = m >>= return . (n +)++test2 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ pushPrompt ps (return 5)+-- 9++test3 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3' = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3'' = (expect 27 =<<) . runCC $+ incr 20 . pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10++test3''' = (print =<<) . runCC $ do+ v <- pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10+ v <- abortP ps (return 9)+ return $ v + 20+-- error++test4 = (expect 35 =<<) . runCC $+ incr 20 . pushPrompt ps $+ incr 10 . takeSubCont ps $ \sk -> + pushPrompt ps (pushSubCont sk (return 5))++test41 = (expect 35 =<<) . runCC $ + incr 20 . pushPrompt ps $ + incr 10 . takeSubCont ps $ \sk -> + pushSubCont sk (pushPrompt ps (pushSubCont sk (abortP ps (return 5))))+++-- Danvy/Filinski's test+--(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))+--; --> 117++test5 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt ps $+ incr 2 . shiftP ps $ \sk -> incr 100 $ sk =<< (sk 3)+-- 117++-- multi-prompt tests++-- Testing prompt flavor P2++test5''1 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p2L $ + incr 2 . (id =<<) . shiftP p2L $ \sk -> + incr 100 $ (sk (pushPrompt p2R+ (sk (sk (abortP p2R (return 3))))))++-- Testing prompt flavor PP++-- Here, p1 and p0 have the same type, and so p0 is actually the same as p1+test5''21 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp++-- Now, p1 and p0 have different types+newtype NInt = NInt{unNInt :: Int} deriving Typeable+test5''22 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (lunNInt (pushPrompt p1+ (lNInt + (sk (sk (abortP p1 (return (NInt 3)))))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp+ lunNInt m = m >>= return . unNInt+ lNInt m = m >>= return . NInt++-- Testing prompt flavor PD+-- p0 and p1 have the same type, but are different+test5''3 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test54 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p0 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test6 = (expect 15 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3)) in+ incr 10 . pushPrompt p1 $ + incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+++-- The most difficult test. The difference between the prompts really matters+-- now+test7 = (expect 135 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk + (takeSubCont p2+ (\sk2 -> pushSubCont sk2+ (pushSubCont sk2 (return 3)))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7'' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135+++-- Checking shift, shift0, control ++testls = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = shiftP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ shiftP ps (\_ -> return xv))+++-- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))+testls0 = (expect [] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps (shift0P ps (\_ -> (shift0P ps (\_ -> return []))))))+ +testls01 = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps + (shift0P ps (\f -> f (shift0P ps (\_ -> return []))) >>= id)))+ ++testlc = (expect [] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\_ -> return xv))+ ++testlc' = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\g -> g xv))+-- ["a"]++testlc1 = (expect 2 =<<) . runCC $+ pushPrompt ps (do+ takeSubCont ps (\sk -> + pushPrompt ps (pushSubCont sk (return 1)))+ takeSubCont ps (\sk -> pushSubCont sk (return 2)))+++-- | traversing puzzle by Olivier Danvy+--+-- >>> traverse shiftP [1,2,3,4,5]+-- [1,2,3,4,5]+-- >>> traverse controlP [1,2,3,4,5]+-- [5,4,3,2,1]++type DelimControl m a b = + Prompt (PS b) m b -> + ((a -> CC (PS b) m b) -> CC (PS b) m b) -> CC (PS b) m a++traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()+traverse op lst = (print =<<) . runCC $+ let visit [] = return []+ visit (h:t) = do+ v <- op ps (\f -> f t >>= (return . (h:)))+ visit v+ in pushPrompt ps (visit lst)
+ CC_Test2.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Tests of the CC Transformer operations: CCExc++module CC_testsT2 where++import Control.Monad.CC.CCExc+import Control.Monad.Trans+import Data.Typeable++expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)+ else error $ "expected " ++ (show ve) +++ ", computed " ++ (show vp)++test1 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5+-- 5++doall = sequence_ [test1, test2, test3, test3', test3'', + test4, test5, test41, test5''1, test5''21, test5''22,+ test5''3, test54,+ test6, test7, test7', test7'',+ testls, testls0, testls01, testlc, testlc', testlc1+ ]++-- | Do all tests+--+-- >>> doall+-- expected answer 5+-- expected answer 9+-- expected answer 9+-- expected answer 9+-- expected answer 27+-- expected answer 35+-- expected answer 117+-- expected answer 35+-- expected answer 115+-- expected answer 117+-- expected answer 115+-- expected answer 115+-- expected answer 117+-- expected answer 15+-- expected answer 135+-- expected answer 135+-- expected answer 135+-- expected answer ["a"]+-- expected answer []+-- expected answer ["a"]+-- expected answer []+-- expected answer ["a"]+-- expected answer 2++-- | test3''' should raise an error+--+-- >>> test3'''+-- *** Exception: Escaping bubble: you have forgotten pushPrompt++incr :: Monad m => Int -> m Int -> m Int+incr n m = m >>= return . (n +)++test2 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ pushPrompt ps (return 5)+-- 9++test3 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3' = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3'' = (expect 27 =<<) . runCC $+ incr 20 . pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10++test3''' = (print =<<) . runCC $ do+ v <- pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10+ v <- abortP ps (return 9)+ return $ v + 20+-- error++test4 = (expect 35 =<<) . runCC $+ incr 20 . pushPrompt ps $+ incr 10 . takeSubCont ps $ \sk -> + pushPrompt ps (pushSubCont sk (return 5))++test41 = (expect 35 =<<) . runCC $ + incr 20 . pushPrompt ps $ + incr 10 . takeSubCont ps $ \sk -> + pushSubCont sk (pushPrompt ps (pushSubCont sk (abortP ps (return 5))))+++-- Danvy/Filinski's test+--(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))+--; --> 117++test5 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt ps $+ incr 2 . shiftP ps $ \sk -> incr 100 $ sk =<< (sk 3)+-- 117++-- multi-prompt tests++-- Testing prompt flavor P2++test5''1 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p2L $ + incr 2 . (id =<<) . shiftP p2L $ \sk -> + incr 100 $ (sk (pushPrompt p2R+ (sk (sk (abortP p2R (return 3))))))++-- Testing prompt flavor PP++-- Here, p1 and p0 have the same type, and so p0 is actually the same as p1+test5''21 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp++-- Now, p1 and p0 have different types+newtype NInt = NInt{unNInt :: Int} deriving Typeable+test5''22 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (lunNInt (pushPrompt p1+ (lNInt + (sk (sk (abortP p1 (return (NInt 3)))))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp+ lunNInt m = m >>= return . unNInt+ lNInt m = m >>= return . NInt++-- Testing prompt flavor PD+-- p0 and p1 have the same type, but are different+test5''3 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test54 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p0 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test6 = (expect 15 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3)) in+ incr 10 . pushPrompt p1 $ + incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+++-- The most difficult test. The difference between the prompts really matters+-- now+test7 = (expect 135 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk + (takeSubCont p2+ (\sk2 -> pushSubCont sk2+ (pushSubCont sk2 (return 3)))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7'' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135+++-- Checking shift, shift0, control ++testls = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = shiftP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ shiftP ps (\_ -> return xv))+++-- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))+testls0 = (expect [] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps (shift0P ps (\_ -> (shift0P ps (\_ -> return []))))))+ +testls01 = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps + (shift0P ps (\f -> f (shift0P ps (\_ -> return []))) >>= id)))+ ++testlc = (expect [] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\_ -> return xv))+ ++testlc' = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\g -> g xv))+-- ["a"]++testlc1 = (expect 2 =<<) . runCC $+ pushPrompt ps (do+ takeSubCont ps (\sk -> + pushPrompt ps (pushSubCont sk (return 1)))+ takeSubCont ps (\sk -> pushSubCont sk (return 2)))+++-- | traversing puzzle by Olivier Danvy+--+-- >>> traverse shiftP [1,2,3,4,5]+-- [1,2,3,4,5]+-- >>> traverse controlP [1,2,3,4,5]+-- [5,4,3,2,1]++type DelimControl m a b = + Prompt (PS b) m b -> + ((a -> CC (PS b) m b) -> CC (PS b) m b) -> CC (PS b) m a++traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()+traverse op lst = (print =<<) . runCC $+ let visit [] = return []+ visit (h:t) = do+ v <- op ps (\f -> f t >>= (return . (h:)))+ visit v+ in pushPrompt ps (visit lst)
+ DocTest.hs view
@@ -0,0 +1,17 @@+import Test.Framework+import Test.Framework.Providers.DocTest (docTest)++-- Test.Framework.Providers.DocTest doesn't export defaultOptions.+defaultOptions = RunnerOptions { ropt_threads = Nothing+ , ropt_test_options = Nothing+ , ropt_test_patterns = Nothing+ , ropt_xml_output = Nothing+ , ropt_xml_nested = Nothing + , ropt_plain_output = Nothing+ , ropt_hide_successes = Nothing+ }++main = do+ let testfiles = ["CC_Test1.hs", "CC_Test2.hs", "Generator1.hs", "Generator2.hs", "ProtocolRecovery.hs"]+ doctests <- docTest testfiles ["-itests"]+ defaultMainWithOpts [doctests] $ defaultOptions { ropt_plain_output = Just True }
Generator1.hs view
@@ -73,18 +73,27 @@ yield label in_order right --- Print out the result of the in-order traversal+-- | Print out the result of the in-order traversal+--+-- >>> test_io+-- 4+-- 2+-- 5+-- 1+-- 6+-- 3+-- 7 test_io :: IO () test_io = runCC $ enumerate (in_order tree1) (liftIO . print) --- 4 2 5 1 6 3 7 --- Or return it as a pure list; the effects are encapsulated+-- | Or return it as a pure list; the effects are encapsulated+--+-- >>> test_st+-- [4,2,5,1,6,3,7] test_st :: [Label] test_st = runST (do res <- newSTRef [] let body v = modifySTRef res (v:) runCC $ enumerate (in_order tree1) (lift . body) readSTRef res >>= return . reverse)---- [4,2,5,1,6,3,7]
Generator2.hs view
@@ -95,13 +95,20 @@ yieldP label in_orderP right --- Print out the result of the in-order traversal+-- | Print out the result of the in-order traversal+--+-- >>> test_ioP+-- 4+-- 2+-- 5+-- 1+-- 6+-- 3+-- 7 test_ioP :: IO () test_ioP = runCC $ enumerateP (in_orderP tree1) (liftIO .(print :: (Int -> IO ()))) --- 4 2 5 1 6 3 7- -- ------------------------------------------------------------------------ -- Using the prompt flavor PM @@ -151,25 +158,35 @@ yield label in_order right --- Print out the result of the in-order traversal+-- | Print out the result of the in-order traversal+--+-- >>> test_io+-- 4+-- 2+-- 5+-- 1+-- 6+-- 3+-- 7 test_io :: IO () test_io = runCC $ enumerate (in_order tree1) (liftIO .(print :: (Int -> IO ()))) --- 4 2 5 1 6 3 7 - -- The second application of control: accumulating the results in a list -- The answer-type for the second prompt. We use newtype for identification newtype Acc a = Acc [a] deriving Typeable toAcc v (Acc l) = return . Acc $ v:l --- The second prompt, used by the acc/accumulated pair+-- | The second prompt, used by the acc/accumulated pair -- Again we use the mark of PM to communicate the type of the elements -- between `acc' and `accumulated'. It happens to be the same type used -- by yield/enumetrate. -- If that was not the case, we could have easily arranged for a type-level -- record (see HList or the TFP paper).+--+-- >>> test_acc+-- [4,2,5,1,6,3,7] pa :: (Typeable a) => Prompt (PM a) m (Acc a) pa = pm @@ -183,8 +200,6 @@ test_acc :: [Label] test_acc = runIdentity . runCC . accumulated $ (enumerate (in_order tree1) acc)---- [4,2,5,1,6,3,7] -- To avoid importing mtl, we define Identity on our own