「圏論やモナドが、どうして文書処理やXMLと関係するのですか？」を読んでるところ

http://d.hatena.ne.jp/m-hiyama/20070125/1169702291
エントリを読んで、演習課題を自分なりにやってみました。ひとしきり読んだんだけど、まだ分からないところがたくさんあるのできっともっと読みます。
課題8でMonadにするところで小一時間ほど悩む。多分、型の使い方が今イチ分かってないんだと思います。

{-
    ProcessTemplate.hs
    http://d.hatena.ne.jp/m-hiyama/20070125
    nisikawa
    2007.03.15
-}
import Data.Maybe
import Text.ParserCombinators.Parsec

-- 課題1
isWellFormed :: String -> Bool
isWellFormed "" = True
isWellFormed s  = iter 0 0 s
  where
    iter l r [] = l == r
    iter l r (x:xs) | x == '{'  = iter (l + 1) r xs
                    | x == '}'  = if l > r   then iter l (r + 1) xs else False
                    | x == '\\' = if null xs then iter l r [] else iter l r (tail xs)
                    | otherwise = iter l r xs

-- 課題2
removeParens :: String -> String
removeParens ""      = ""
removeParens (x:xs) | isParens x = removeParens xs
                    | x == '\\'  = if null xs then [x]
                                   else x:y:removeParens (tail xs)
                    | otherwise  = x:removeParens xs
    where y = head xs

isParens c = c `elem` "{}"

-- 課題3(以下エスケープは無視,メンドーだから)
data Value a  = Text a | Block a [Value a] deriving Show

run line = case runParser parseTemplate "" [] line of
        Left e  -> error $ show e
        Right x -> x

parseTemplate = do
    x  <- (try block) <|> text
    xs <- (try parseTemplate) <|> return []
    return (x:xs)

block = do
    char '{'
    b  <- (try (many1 (noneOf "{}"))) <|> return ""
    bs <- (try parseTemplate) <|> return []
    char '}'
    return $ Block b bs

text = do
    t <- many1 $ noneOf "{}"
    return $ Text t

type Template = String
type Context  = [(String,String)]

processTemplate :: Template -> Context -> Template
processTemplate template ctx = let vals = run template in f vals ctx
  where f [] _  = ""
        f ((Text t):xs) ctx     = t ++ f xs ctx
        f ((Block b bs):xs) ctx = let ms = lookup b ctx
                                  in case ms of
                                       Nothing -> blocked (b ++ f bs []) ++ f xs ctx
                                       Just s  -> s ++ f bs [] ++ f xs ctx


blocked b = "{" ++ b ++ "}"

processContext :: Context -> Context -> Context
processContext c ctx | null ctx  = c
                     | otherwise = map (\(x,y) -> (x, processTemplate y ctx)) c

data T = T Template | C Context deriving Show

process :: T -> T -> T
process x (T _) = x
process (T t) (C ctx) = T $ processTemplate t ctx
process (C c) (C ctx) = C $ processContext c ctx

-- 課題4
notNestedBlocks template = f $ run template
  where f [] = []
        f ((Text t):xs) = f xs
        f ((Block b []):xs) = b:f xs
        f ((Block b bs):xs) = f bs ++ f xs

-- 課題5
removeNestedBlockParens template = f $ run template
  where f [] = []
        f ((Text t):xs) = t ++ f xs
        f ((Block b []):xs) = blocked b ++ f xs
        f ((Block b bs):xs) = b ++ f bs ++ f xs

-- 課題6
nestLevel = nestLevel' . run

nestLevel' :: [Value a] -> Int
nestLevel' []   = 0
nestLevel' vals = maximum $ map f vals
  where f (Text t) = 0
        f (Block b bs) = 1 + nestLevel' bs

-- 課題7
data Templ a = Templ a deriving (Show, Eq)

processTemplate' :: Templ String -> (String -> Templ String) -> Templ String
processTemplate' (Templ t) fun = let vals = run t in f vals fun
  where f [] _ = Templ []
        f ((Text t):xs) fun     = let (Templ s)  = f xs fun in Templ $ t ++ s
        f ((Block b bs):xs) fun = let (Templ s1) = fun b
                                      (Templ s2) = f bs unit
                                      (Templ s3) = f xs fun
                                  in Templ $ s1 ++ s2 ++ s3

-- "{ho{gefu}ga}"みたいのをうまく展開できない...Templはネストしないからいいのかな。
con :: Context -> String -> Templ String
con ctx b = Templ $ fromMaybe (blocked b) (lookup b ctx)

unit :: String -> Templ String
unit = Templ . blocked

ext :: (String -> Templ String) -> Templ String -> Templ String
ext f = flip processTemplate' f

-- 課題8
con1 = con [("hoge","111"),("fuga","222"),("piyo","333")]
con2 = con [("111","AAA"),("222","BBB"),("333","CCC")]
t = Templ "hoge{fuga}{piyo}"

f1 = (ext unit) (Templ "hoge") == Templ "hoge"
f2 = (ext con1) (unit "hoge")  == Templ "111"
f3 = (ext((ext con2) . con1)) t == (ext con2 . ext con1) t