-- 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]