Haskell version of "A Schemer's View of Monads"

schemers-monads.hs

module Foo where

-- This is a translation to Haskell of parts of the paper
-- "A Schemer's View of Monads" by Adam C. Foltzer & Daniel P. Friedman:
--
-- https://cgi.soic.indiana.edu/~c311/lib/exe/fetch.php?media=manymonads.pdf

import Control.Monad.State

-- `Tree a` is a way of describing only those S-exps which are trees
-- as an alternative to the standard definition of S-exps:
--
--   data Sexp a = Nil | Val a | Cons (Sexp a) (Sexp a)

data Tree a = Nil | ConsT (Tree a) (Tree a) | ConsV a (Tree a)
  deriving (Show)

add1 x = x+1

rememberEvens :: Tree Int -> Tree Int
rememberEvens Nil = Nil
rememberEvens (ConsT a b) = ConsT (rememberEvens a) (rememberEvens b)
rememberEvens (ConsV a b)
  | odd a     = ConsV a (rememberEvens b)
  | otherwise  = rememberEvens b

countEvens :: Tree Int -> Int
countEvens Nil = 0
countEvens (ConsT a b) = countEvens a + countEvens b
countEvens (ConsV a b)
  | even a     = add1 (countEvens b)
  | otherwise  = countEvens b

-- ’(2 3 (7 4 5 6) 8 (9) 2))

subtree1 = ConsV 7 (ConsV 4 (ConsV 5 (ConsV 6 Nil)))
subtree2 = ConsV 9 Nil
tree1 :: Tree Int
tree1 = ConsV 2 (ConsV 3 (ConsT subtree1
                                (ConsV 8 (ConsT subtree2
                                                (ConsV 2 Nil)))))

test1 = (countEvens tree1, rememberEvens tree1)

-- Continuation passing style.

cps Nil k = k ((0::Int), Nil)
cps (ConsT a b) k = 
  cps a (\(ca, ra) -> cps b (\(cb, rb) -> k (ca+cb, ConsT ra rb)))
cps (ConsV a b) k = 
  cps b (\(cb, rb) ->
     if even a
       then k (add1 cb, rb)
       else k (cb, ConsV a rb))

test2 = cps tree1 id

-- Monadic version.

rememberState :: Tree Int -> State Int (Tree Int)
rememberState Nil = return Nil
rememberState (ConsT a b) = do
  as <- rememberState a
  bs <- rememberState b
  return $ ConsT as bs
rememberState (ConsV a b) = do
  bs <- rememberState b
  if even a
    then do modify add1
            return bs
    else return $ ConsV a bs

test3 = runState (rememberState tree1) (0::Int)