X-Git-Url: https://git.distorted.org.uk/~mdw/fringe/blobdiff_plain/2bd37ef118cb1e41cb0e9e2332a9eb69ac2f2df4..e4e035bf5fd8c6d99eecff9db55cdd4a4b069fbe:/haskell-fringe.hs

diff --git a/haskell-fringe.hs b/haskell-fringe.hs
index 577bb6b..4ca9a3e 100644
--- a/haskell-fringe.hs
+++ b/haskell-fringe.hs
@@ -7,49 +7,82 @@ 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)
+data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show)
 
 -- Return the elements inorder, as a list.
 fringe t = gather t [] where
   gather Leaf ns = ns
-  gather (Node (l, x, r)) ns = gather l (x : gather r ns)
+  gather (Node l x r) ns = gather l (x : gather r ns)
 
 -- 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.