From d87584d71b1c587112f039ab69a5af8b083b18be Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 18 Nov 2009 16:38:06 +0000
Subject: [PATCH] haskell: Tidy up the parser using proper monadic combinators.

Hope this isn't too complicated.
---
 haskell-fringe.hs | 81 ++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 57 insertions(+), 24 deletions(-)

diff --git a/haskell-fringe.hs b/haskell-fringe.hs
index 577bb6b..78c6362 100644
--- a/haskell-fringe.hs
+++ b/haskell-fringe.hs
@@ -7,6 +7,55 @@ import System
 import Monad
 
 -----------------------------------------------------------------------------
+-- Parser combinators.
+
+-- A very simple parser monad.
+newtype Parser t a = Parser { runparse :: [t] -> Either String (a, [t]) }
+
+instance Monad (Parser t) where
+  return x = Parser $ \ts -> Right (x, ts)
+  fail err = Parser $ \_ -> Left err
+  (Parser p) >>= f = Parser $ \ts -> case p ts of
+                                       Right (x, ts) -> runparse (f x) ts
+                                       Left err -> Left err
+
+-- Access to the token stream.
+peek = Parser $ \ts -> case ts of
+                         t:_ -> Right (Just t, ts)
+                         _ -> Right (Nothing, ts)
+
+step = Parser $ \ts -> case ts of
+                         _:ts -> Right ((), ts)
+                         _ -> Left "unexpected end-of-file"
+
+-- Run a parser, getting the final value out.
+parse ts p = case runparse p ts of
+               Right (x, _) -> Right x
+               Left err -> Left err
+
+-- If the current token satisfies PRED then return it; otherwise fail with
+-- ERR.
+satisfies pred err = do
+  r <- peek
+  case r of
+    Just t | pred t -> do step; return t
+    _ -> fail err
+
+-- Return the next token if there is one; otherwise fail with ERR.
+anytok err = satisfies (const True) err
+
+-- If the current character matches D then return it; otherwise fail with a
+-- suitable error.
+delim d = satisfies (\c -> c == d) ("missing " ++ [d])
+
+-- If at end of file then succeed; otherwise fail with a suitable error.
+eof = do
+  r <- peek
+  case r of
+    Nothing -> return ()
+    _ -> fail "trailing junk"
+
+-----------------------------------------------------------------------------
 -- Tree data type.
 
 data Tree a = Leaf | Node (Tree a, a, Tree a) deriving (Show)
@@ -19,37 +68,21 @@ fringe t = gather t [] where
 -- Answer whether two trees have the same fringe.
 sameFringe t tt = fringe t == fringe tt -- trivial!
 
------------------------------------------------------------------------------
--- Parsing.
-
--- Turn Either String a into a monad expressing computatations which can fail
--- with a useful error message.
-instance Monad (Either String) where
-  return = Right
-  fail = Left
-  Right x >>= f = f x
-  Left l >>= _ = Left l
-
 -- Parse a tree from the description in CS.  The syntax is:
 --
 --      tree ::= empty | `(' tree char tree `)'
 --
 -- disambiguated by deciding that `(' starts a tree wherever a tree is
 -- expected.
-parseTree cs = do
-  (t, cs) <- parse cs
-  if cs == [] then return t else fail "trailing junk"
+parseTree cs = parse cs $ do t <- tree; eof; return t
  where
-  parse ('(':cs) = do
-    (left, cs) <- parse cs
-    case cs of
-      [] -> fail "no data"
-      (c:cs) -> do
-        (right, cs) <- parse cs
-        case cs of
-          (')':cs) -> return (Node (left, c, right), cs)
-          _ -> fail "missing )"
-  parse cs = return (Leaf, cs)
+  tree = do
+    r <- peek
+    case r of
+      Just '(' -> do
+        step; left <- tree; c <- anytok "no data"; right <- tree; delim ')'
+        return $ Node (left, c, right)
+      _ -> return Leaf
 
 -----------------------------------------------------------------------------
 -- Main program.
-- 
2.11.0