-- Copyright 2009 Leon P Smith
-- This code is provided under the Creative Commons Attribution Only license
-- This file demonstrates that the continuation transformer in [Liang 1995]
-- fails to meet the correctness criteria set out in the paper. We demonstrate
-- an expression that depends on lazy state monads, and gets stuck in an infinite
-- nonproductive loop when run with a continuation transformer, even though
-- continuations aren't used.
-- S. Liang, P. Hudak, and M. Jones "Monad Transformers and Modular Interpreters",
-- Proceedings of the 22nd ACM Symposium on Principles of Programming Languages, 1995
-- http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.17.268
{-# LANGUAGE FlexibleContexts #-}
import Control.Monad.State
import Control.Monad.Cont
import Control.Monad.Identity
import Data.Ratio
data Queue e = Queue [e] [e]
empty = Queue [] []
enqueue e (Queue as zs) = Queue as (e:zs)
dequeue (Queue [] []) = (Nothing , Queue [] [])
dequeue (Queue [] zs) = dequeue (Queue (reverse zs) [])
dequeue (Queue (a:as) zs) = (Just a , Queue as zs)
enQ :: (MonadState (Queue a) m) => a -> m ()
enQ e = do
q <- get
put (enqueue e q)
deQ :: (MonadState (Queue a) m) => m (Maybe a)
deQ = do
q <- get
let (a, q') = dequeue q
put q'
return a
foldrByLevel :: (MonadState (Queue a) m)
=> (a -> [a])
-> (a -> b -> b) -> b -> [a] -> m b
foldrByLevel childrenOf f b as = fold as
where
fold [] = deQ >>= maybe (return b)
(\a -> fold (childrenOf a))
fold (a:as) = do
enQ a
b <- fold as
return (f a b)
data Tree a b = Leaf a | Branch b (Tree a b) (Tree a b)
childrenOf (Leaf _ ) = []
childrenOf (Branch _ l r) = [l,r]
labelDisj leaf branch (Leaf a ) = leaf a
labelDisj leaf branch (Branch b _ _) = branch b
fib n = fibs !! (n - 1)
where
fibs = Leaf 0 : Leaf 0 : zipWith3 Branch [1..] fibs (tail fibs)
sternBrocot :: Tree a (Ratio Integer)
sternBrocot = loop 0 1 1 0
where
loop a b x y
= Branch (m%n) (loop a b m n) (loop m n x y)
where
m = a + x
n = b + y
levelOrder :: (MonadState (Queue (Tree t t)) m) => [Tree t t] -> m [t]
levelOrder = foldrByLevel childrenOf (labelDisj (:) (:)) []
runS m = liftM fst (runStateT m empty)
runC m = runContT m return
runI m = runIdentity m
levelOrderS = runI . runS . levelOrder
levelOrderSC = runI . runC . runS . levelOrder
levelOrderCS = runI . runS . runC . levelOrder
productive = levelOrderS [sternBrocot]
nonproductive = levelOrderSC [sternBrocot]
nonproductive' = levelOrderCS [sternBrocot]