code from The Craft of Functional Programing, chapter 19

gistfile1.txt

import System.IO
import Prelude hiding (lookup)

while test action = do
    res <- test
    if res
       then do action >> while test action
       else return ()

copy = while (do {x  <- isEOF; return (not x)}) (getLine >>= putStr)

copy2 = do
    res <- isEOF
    if (not res)
       then getLine >>= (\x -> if null x then return () else  putStrLn x >> copy2)
       else return ()

sumInt = do
    x <- fmap read getLine
    if (x == 0)
        then return 0
        else do
            y <- sumInt
            return $ x + y


errorCatch = do
    catch (readFile "Non-exixt-file") (\e -> return "n")

data Id a = Id a


instance Monad Id where
    return = Id
    (Id a) >>= f = f a

data Tree a = Nil
            | Node a (Tree a) (Tree a)

sumTree Nil = 0
sumTree (Node a t1 t2) = sumTree t1 + sumTree t2 + a

sumTreeSt :: (Monad m) => Tree Int -> m Int
sumTreeSt Nil = return 0
sumTreeSt (Node a t1 t2) = do
    n1 <- sumTreeSt t1
    n2 <- sumTreeSt t2
    return (a + n1 + n2)

runId (Id a) = a


{-- utilze state monad --}

numTree :: Eq a => Tree a -> Tree Int
numTree = extract . numberTree

numberTree :: Eq a => Tree a -> State a (Tree Int)
numberTree Nil = return Nil
numberTree (Node x t1 t2) = do
    num <- numberNode x
    nt1 <- numberTree t1
    nt2 <- numberTree t2
    return (Node num nt1 nt2)

numberNode :: Eq a => a -> State a Int
numberNode x = State (nNode x)

nNode :: Eq a => a -> (Table a -> (Table a, Int))
nNode x table
    | x `elem` table = (table, lookup x table)
    | otherwise      = (table ++ [x], length table)

type Table a = [a]

lookup :: Eq a => a -> Table a -> Int
lookup x [] = 0
lookup x (y:ys)
    | x == y = 1
    | otherwise = 1 + lookup x ys

data State a b = State (Table a -> (Table a, b))

extract :: State a b -> b
extract (State st) = snd (st [])

instance Monad (State a) where
    return x = State $ (\tab -> (tab, x))
    (State st) >>= f =
        State $ \tab ->
            let (newTab, y) = st tab
                (State trans) = f y
            in trans newTab