1 --------------------------------------------------
    2 -- Copyright 1994 by Peter Thiemann
    3 -- $Log: Parsers.hs,v $
    4 -- Revision 1.1  1996/01/08 20:02:32  partain
    5 -- Initial revision
    6 --
    7 -- Revision 1.3  1994/03/15  15:34:53  thiemann
    8 -- minor revisions
    9 --
   10 --Revision 1.2  1993/08/31  12:31:32  thiemann
   11 --reflect changes in type FONT
   12 --
   13 --Revision 1.1  1993/08/17  12:34:29  thiemann
   14 --Initial revision
   15 --
   16 -- $Locker:  $
   17 --------------------------------------------------
   18 module Parsers where
   19 
   20 infixl 6 `using`, `using2`
   21 infixr 7 `alt`
   22 infixr 8 `thn`, `xthn`, `thnx` 
   23 
   24 type Parser a b = [a] -> [(b, [a])]
   25 
   26 succeed :: beta -> Parser alpha beta
   27 succeed value tokens = [(value, tokens)]
   28 
   29 -- the parser
   30 --      satisfy p
   31 -- accepts the language { token | p(token) }
   32 
   33 satisfy :: (alpha -> Bool) -> Parser alpha alpha
   34 satisfy p [] = []
   35 satisfy p (token:tokens) | p token = succeed token tokens
   36                          | otherwise = []
   37 
   38 -- the parser
   39 --      literal word
   40 -- accepts { word }
   41 
   42 literal :: Eq alpha => alpha -> Parser alpha alpha
   43 literal token = satisfy (== token)
   44 
   45 -- if p1 and p2 are parsers accepting L1 and L2 then
   46 --      then p1 p2
   47 -- accepts L1.L2
   48 
   49 thn :: Parser alpha beta -> Parser alpha gamma -> Parser alpha (beta, gamma)
   50 thn p1 p2 =
   51         concat
   52         . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 tokens1))
   53         . p1
   54 
   55 thnx :: Parser alpha beta -> Parser alpha gamma -> Parser alpha beta
   56 thnx p1 p2 = 
   57         concat
   58         . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 tokens1))
   59         . p1
   60 
   61 xthn :: Parser alpha beta -> Parser alpha gamma -> Parser alpha gamma
   62 xthn p1 p2 =
   63         concat
   64         . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2, tokens2)) (p2 tokens1))
   65         . p1
   66 
   67 
   68 -- if p1 and p2 are parsers accepting L1 and L2 then
   69 --      alt p1 p2
   70 -- accepts L1 \cup L2
   71 
   72 alt :: Parser alpha beta -> Parser alpha beta -> Parser alpha beta
   73 alt p1 p2 tokens = p1 tokens ++ p2 tokens
   74 
   75 -- if p1 is a parser then
   76 --      using p1 f
   77 -- is a parser that accepts the same language as p1
   78 -- but mangles the semantic value with f
   79 
   80 using :: Parser alpha beta -> (beta -> gamma) -> Parser alpha gamma
   81 using p1 f = map (\ (v, tokens) -> (f v, tokens)) . p1
   82 
   83 using2 :: Parser a (b,c) -> (b -> c -> d) -> Parser a d
   84 using2 p f = map ( \((v,w), tokens) -> (f v w, tokens)) . p
   85 
   86 -- if p accepts L then plus p accepts L+
   87 
   88 plus :: Parser alpha beta -> Parser alpha [beta]
   89 plus p = (p `thn` rpt p) `using2` (:)
   90 
   91 -- if p accepts L then rpt p accepts L*
   92 
   93 rpt :: Parser alpha beta -> Parser alpha [beta]
   94 rpt p = plus p `alt` succeed []
   95 
   96 -- if p accepts L then opt p accepts L?
   97 
   98 opt :: Parser alpha beta -> Parser alpha [beta]
   99 opt p = (p `using` \x -> [x]) `alt` succeed []
  100 
  101 -- followedBy p1 p2 recognizes L(p1) if followed by a word in L (p2)
  102 
  103 followedBy :: Parser a b -> Parser a c -> Parser a b
  104 followedBy p q tks = [(v, rest) | (v, rest) <- p tks, x <- q rest]