1 module ParseLib where
    2 
    3 import Char
    4 
    5 type Parser a = String -> [(a, String)]
    6 
    7 -- Trivial Parser:
    8 
    9 empty :: Parser [a]
   10 empty = (\x -> [([], x)])
   11 
   12 -- Parser Generators:
   13 
   14 character' :: Char -> Parser Char
   15 character' c x   | null x               = []
   16                         | c == head x               = [(head x, tail x)]
   17                         | otherwise   = []
   18 
   19 parse_if' :: (Char -> Bool) -> Parser Char
   20 parse_if' p x     | null x         = []
   21                         | p (head x)         = [(head x, tail x)]
   22                         | otherwise   = []
   23 
   24 string' :: String -> Parser String
   25 string' s x         | s == fst split   = [split]
   26                         | otherwise   = []
   27   where
   28         split                        = splitAt (length s) x
   29 
   30 parse_while' :: (Char -> Bool) -> Parser String
   31 parse_while' p x        | null x             = []
   32                         | p (head x)         = [span p x]
   33                         | otherwise   = []
   34 
   35 -- Elementary Parser Combinators:
   36 
   37 choice :: [Parser r] -> Parser r
   38 choice ps x = [r | p <- ps, r <- p x]
   39 
   40 sequence2 :: Parser r1 -> Parser r2 -> Parser (r1, r2)
   41 sequence2 p1 p2 x0 = [((r1, r2), x2) | (r1, x1) <- p1 x0, (r2, x2) <- p2 x1]
   42 
   43 sequence3 :: Parser r1 -> Parser r2 -> Parser r3 -> Parser (r1, r2, r3)
   44 sequence3 p1 p2 p3 x0 = [((r1, r2, r3), x3) | (r1, x1) <- p1 x0, (r2, x2) <- p2 x1, (r3, x3) <- p3 x2]
   45 
   46 -- Parser Transformers:
   47 
   48 transform :: (a -> b) -> Parser a -> Parser b
   49 transform f p s = [(f r, x) | (r, x) <- p s]
   50 
   51 allow_null :: Parser [a] -> Parser [a]
   52 allow_null p x  | null result    = [([], x)]
   53                 | otherwise   = result
   54   where
   55         result                = p x
   56 
   57 forbid_null :: Parser [a] -> Parser [a]
   58 forbid_null p = filter (\(r, x) -> (not . null) r) . p
   59 
   60 -- More Parser Combinators:
   61 
   62 cons :: Parser a -> Parser [a] -> Parser [a]
   63 cons p ps = transform (\(a, as) -> a : as) (sequence2 p ps)
   64 
   65 repetition0 :: Parser a -> Parser [a]
   66 repetition0 p = allow_null (cons p (repetition0 p))
   67 
   68 repetition1 :: Parser a -> Parser [a]
   69 repetition1 p = (cons p (repetition0 p))
   70 
   71 option :: Parser a -> Parser [a]
   72 option p = choice [transform (\a -> [a]) p, empty]
   73 
   74 -- Parser Combinators:
   75 
   76 remove_left :: Parser a -> Parser b -> Parser b
   77 remove_left p1 p2 = transform snd (sequence2 p1 p2)
   78 
   79 remove_right :: Parser a -> Parser b -> Parser a
   80 remove_right p1 p2 = transform fst (sequence2 p1 p2)
   81 
   82 enclose :: Parser a -> Parser b -> Parser c -> Parser b
   83 enclose p1 p2 p3              = transform take_mid (sequence3 p1 p2 p3)
   84   where
   85         take_mid (a, b, c)     = b
   86 
   87 glue :: Parser a -> Parser b -> Parser c -> Parser (a, c)
   88 glue p1 p2 p3      = transform drop_mid (sequence3 p1 p2 p3)
   89   where
   90         drop_mid (a, b, c)     = (a, c)
   91 
   92 -- Elementary Parser:
   93 
   94 whitespace :: Parser String
   95 whitespace = allow_null (parse_while' isSpace)
   96 
   97 -- More Parser Generators:
   98 
   99 character :: Char -> Parser Char
  100 character c = remove_left whitespace (character' c)
  101 
  102 parse_if :: (Char -> Bool) -> Parser Char
  103 parse_if p = remove_left whitespace (parse_if' p)
  104 
  105 string :: String -> Parser String
  106 string s = remove_left whitespace (string' s)
  107 
  108 parse_while :: (Char -> Bool) -> Parser String
  109 parse_while p = remove_left whitespace (parse_while' p)
  110 
  111 -- Final routine:
  112 
  113 parse :: Parser a -> String -> [a]
  114 parse parser = map fst . filter (null . snd) . parser