liboleg-2010.1.9.0: Control/Generator2.hs
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
-- | Generators in Haskell
--
-- We translate the in-order tree traversal example from an old article
-- Generators in Icon, Python, and Scheme, 2004.
--
-- > http://okmij.org/ftp/Scheme/enumerators-callcc.html#Generators
--
-- using Haskell and delimited continuations rather than call/cc + mutation.
-- The code is shorter, and it even types.
-- To be honest, we actually translate the OCaml code generator.ml
--
-- This code is the extension of Generator1.hs; we use delimited
-- control not only to implement the generator. We also use delimited
-- control to accumulate the results in a list. We need two different
-- prompts then (with two different answer-types, as it happens).
-- This file illustrates the prompt flavors PP and PM, using newtypes
-- to define private global prompts (global prompts that are private to
-- the current module).
--
--
module Control.Generator2 where
import Control.CCExc
import Control.Monad.Trans (liftIO, lift)
import Data.Typeable
{-
A sample program Python programmers seem to be proud of: an in-order
traversal of a tree:
>>>> # A recursive generator that generates Tree leaves in in-order.
>>> def inorder(t):
... if t:
... for x in inorder(t.left):
... yield x
... yield t.label
... for x in inorder(t.right):
... yield x
Given below is the complete implementation in Haskell.
-}
-- | A few preliminaries: define the tree and build a sample tree
--
type Label = Int
data Tree = Leaf | Node Label Tree Tree deriving Show
make_full_tree :: Int -> Tree
make_full_tree depth = loop 1 depth
where
loop label 0 = Leaf
loop label n = Node label (loop (2*label) (pred n)) (loop (2*label+1) (pred n))
tree1 = make_full_tree 3
-- | In Python, `yield' is a keyword. In Haskell, it is a regular function.
-- Furthermore, it is a user-defined function, in one line of code.
-- To get generators there is no need to extend a language.
--
-- First, we try the prompt flavor PP
--
-- The answer-type for one of the prompts
newtype ResP m a = ResP ( (a -> CC PP m ()) -> CC PP m () )
instance Typeable1 m => Typeable1 (ResP m) where
typeOf1 x = mkTyConApp (mkTyCon "ResP") [m]
where m = typeOf1 (undefined:: m ())
outResP body (ResP f) = f body
-- | One prompt, used by the generator (the yield/enumerate pair)
-- We instantiate the global pp to the desired answer-type.
ppy :: (Typeable1 m, Typeable a) => Prompt PP m (ResP m a)
ppy = pp
-- | The rest of the code, up to test_io, is the same as that in Generator1.hs
yieldP :: (Typeable1 m, Typeable a) => Monad m => a -> CC PP m ()
yieldP v = shift0P ppy (\k -> return . ResP $ \b -> b v >> k () >>= outResP b)
-- | The enumerator: the for-loop essentially
enumerateP :: (Typeable1 m, Typeable a, Monad m) =>
CC PP m () -> (a -> CC PP m ()) -> CC PP m ()
enumerateP iterator body =
pushPrompt ppy (iterator >> (return . ResP . const $ return ())) >>=
outResP body
-- | The in_order function itself: compare with the Python version
in_orderP :: (Typeable1 m, Monad m) => Tree -> CC PP m ()
in_orderP Leaf = return ()
in_orderP (Node label left right) = do
in_orderP left
yieldP label
in_orderP right
-- | Print out the result of the in-order traversal
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
--
-- The above code works. We can define the second pair of operators
-- to accummulate the result into a list. Yet, the solution is
-- not very satisfactory. We notice that the prompt type ppy is
-- polymorphic over a, the elements we yield. What ensures that
-- `yieldP' yields elements of the same type that enumerateP can pass to the
-- body of the loop? Nothing, actually, at compile time. If yieldP and
-- enumerateP do not agree on the type of the elements, a run-time
-- error will occur.
-- This is where the PM prompt type comes in handy. It has a phantom
-- type parameter c, which can be used to communicate between
-- producers and consumers of the effect. We use the type parameter c
-- to communicate the type of elements, between yield and enumerate.
-- Since the parameter is phantom, it costs us nothing at run-time.
--
-- The answer-type for one of the prompts
newtype Res m a = Res ( (a -> CC (PM a) m ()) -> CC (PM a) m () )
instance Typeable1 m => Typeable1 (Res m) where
typeOf1 x = mkTyConApp (mkTyCon "Res") [m]
where m = typeOf1 (undefined:: m ())
outRes body (Res f) = f body
-- | One prompt, used by the generator (the yield/enumerate pair)
py :: (Typeable1 m, Typeable a) => Prompt (PM a) m (Res m a)
py = pm
-- | The rest of the code, up to test_io, is the same as that in Generator1.hs
yield :: (Typeable1 m, Typeable a) => Monad m => a -> CC (PM a) m ()
yield v = shift0P py (\k -> return . Res $ \b -> b v >> k () >>= outRes b)
-- | The enumerator: the for-loop essentially
enumerate :: (Typeable1 m, Typeable a, Monad m) =>
CC (PM a) m () -> (a -> CC (PM a) m ()) -> CC (PM a) m ()
enumerate iterator body =
pushPrompt py (iterator >> (return . Res . const $ return ())) >>=
outRes body
-- | The in_order function itself: compare with the Python version
in_order :: (Typeable1 m, Monad m) => Tree -> CC (PM Label) m ()
in_order Leaf = return ()
in_order (Node label left right) = do
in_order left
yield label
in_order right
-- | Print out the result of the in-order traversal
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
-- 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).
pa :: (Typeable a) => Prompt (PM a) m (Acc a)
pa = pm
acc :: (Typeable a, Monad m) => a -> CC (PM a) m ()
acc v = shift0P pa (\k -> k () >>= toAcc v)
accumulated :: (Typeable a, Monad m) => CC (PM a) m () -> CC (PM a) m [a]
accumulated body =
pushPrompt pa (body >> return (Acc [])) >>= \ (Acc l) -> return l
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
newtype Identity a = Identity{runIdentity :: a} deriving (Typeable)
instance Monad Identity where
return = Identity
m >>= f = f $ runIdentity m