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