1 files changed, 92 insertions, 0 deletions
diff --git a/utils/heap-view/Parse.lhs b/utils/heap-view/Parse.lhs
new file mode 100644
index 0000000000..9d7652fdcc
--- /dev/null
+++ b/utils/heap-view/Parse.lhs
@@ -0,0 +1,92 @@
+> module Parse where
+
+The Parser monad in "Comprehending Monads"
+
+> infixr 9 `thenP`
+> infixr 9 `thenP_`
+> infixr 9 `plusP`
+
+> type P t a = [t] -> [(a,[t])]
+
+> unitP :: a -> P t a
+> unitP a = \i -> [(a,i)]
+
+> thenP :: P t a -> (a -> P t b) -> P t b
+> m `thenP` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k a i1]
+
+> thenP_ :: P t a -> P t b -> P t b
+> m `thenP_` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k i1]
+
+zeroP is the parser that always fails to parse its input
+
+> zeroP :: P t a
+> zeroP = \i -> []
+
+plusP combines two parsers in parallel
+(called "alt" in "Comprehending Monads")
+
+> plusP :: P t a -> P t a -> P t a
+> a1 `plusP` a2 = \i -> (a1 i) ++ (a2 i)
+
+itemP is the parser that parses a single token
+(called "next" in "Comprehending Monads")
+
+> itemP :: P t t
+> itemP = \i -> [(head i, tail i) | not (null i)]
+
+force successful parse
+
+> cutP :: P t a -> P t a
+> cutP p = \u -> let l = p u in if null l then [] else [head l]
+
+find all complete parses of a given string
+
+> useP :: P t a -> [t] -> [a]
+> useP m =  \x -> [ a | (a,[]) <- m x ]
+
+find first complete parse
+
+> theP :: P t a -> [t] -> a
+> theP m = head . (useP m)
+
+
+Some standard parser definitions
+
+mapP applies f to all current parse trees
+
+> mapP :: (a -> b) -> P t a -> P t b
+> f `mapP` m =  m `thenP` (\a -> unitP (f a))
+
+filter is the parser that parses a single token if it satisfies a
+predicate and fails otherwise.
+
+> filterP :: (a -> Bool) -> P t a -> P t a
+> p `filterP` m = m `thenP` (\a -> (if p a then unitP a else zeroP))
+
+lit recognises literals
+
+> litP :: Eq t => t -> P t ()
+> litP t = ((==t) `filterP` itemP) `thenP` (\c -> unitP () )
+
+> showP :: (Text a) => P t a -> [t] -> String
+> showP m xs = show (theP m xs)
+
+
+Simon Peyton Jones adds some useful operations:
+
+> zeroOrMoreP :: P t a -> P t [a]
+> zeroOrMoreP p = oneOrMoreP p `plusP` unitP []
+
+> oneOrMoreP :: P t a -> P t [a]
+> oneOrMoreP p = seq p
+>  where seq p = p		`thenP` (\a ->
+>		(seq p		`thenP` (\as -> unitP (a:as)))
+>		`plusP`
+>		unitP [a] )
+
+> oneOrMoreWithSepP :: P t a -> P t b -> P t [a]
+> oneOrMoreWithSepP p1 p2 = seq1 p1 p2
+>   where seq1 p1 p2 =	p1 `thenP` (\a -> seq2 p1 p2 a `plusP`  unitP [a])
+>         seq2 p1 p2 a =	p2		`thenP` (\_ ->
+>				seq1 p1 p2	`thenP` (\as -> unitP (a:as) ))
+