-- Combinator Parsing
-- Carsten Schuermann:  From: Monadic Parser Combinators [Hutton, Meijer]

type Parser a = String -> [(a, String)]

result :: a -> Parser a
result v = \s -> [(v, s)]

zero :: Parser a
zero = \s -> []

item :: Parser Char
item = \s -> (case s of 
             [] -> []
	     (c : s') -> [(c, s')])

bind :: Parser a -> (a -> Parser b) -> Parser b
p `bind` f = \s -> concat [f v s' | (v, s') <- p s]

sat :: (Char -> Bool) -> Parser Char
sat p = item `bind` \c -> if p c then result c else zero

char :: Char -> Parser Char
char x = sat (\y -> x == y)

digit :: Parser Char
digit = sat (\x -> '0' <= x && x <= '9')

lower :: Parser Char
lower = sat (\x -> 'a' <= x && x <= 'z')

upper :: Parser Char
upper = sat (\x -> 'A' <= x && x <= 'Z')

plus :: Parser a -> Parser a -> Parser a
p `plus` q = \s -> (p s ++ q s) 

letter :: Parser Char
letter = lower `plus` upper

alphanum :: Parser Char
alphanum = letter `plus` digit

word :: Parser String
word = neWord `plus` result ""
       where neWord = letter `bind` \x ->
		      word `bind` \s -> 
			  result (x : s)

string :: String -> Parser String 
string "" = result ""
string (x:xs) = char x `bind` \_ ->
		string xs `bind` \_ ->
		result (x : xs)


--  Simple repetition

many :: Parser a -> Parser [a]
many p =  (p `bind` \x ->
	  many p `bind` \xs ->
	  result (x:xs)) `plus` result []

ident :: Parser String
ident = lower `bind` \x -> 
	many alphanum `bind` \xs ->
	result (x:xs)

many1 :: Parser a -> Parser [a]
many1 p = p `bind` \x -> 
          many p `bind` \xs -> 
	  result (x:xs)


nat :: Parser Int
nat = many1 digit `bind` \xs -> 
      result (eval xs)
	   where
	      eval xs = foldl1 op [ord x - ord '0' | x <- xs]
	      m `op` n = 10*m+n

-- 4.3 Parsing expressions



expr :: Parser Int
addop :: Parser (Int -> Int -> Int)
factor :: Parser Int


bracket  :: Parser a -> Parser b -> Parser c -> Parser b
bracket open p close = 
    open  `bind` \_ ->
    p     `bind` \x ->
    close `bind` \_ ->
    result x


-- Problem:  expr below is left recursive!
expr' = (expr' `bind` \x ->
	 addop `bind` \f -> 
	 factor `bind` \y -> 
	 result (f x y)) 
	`plus` factor

expr'' = factor `bind` \x ->
       many (addop `bind` \f -> 
	     factor `bind` \y -> 
	     result (f, y)) `bind` \fys ->
       result (foldl (\x (f, y) -> f x y) x fys)


addop' = (char '+' `bind` \_ ->
	 result (+))
	`plus`
	(char '-' `bind` \_ ->
	 result (-))

-- parsers non empty list of elements sep by operators associated to the left

chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
p `chainl1` op = 
    p `bind` \x ->
    many (op `bind` \f -> 
	  p `bind` \y -> 
	  result (f, y)) `bind` \fys ->
    result (foldl (\x (f, y) -> f x y) x fys)


-- lists of operators

ops :: [(Parser a, b)] -> Parser b
ops xs = foldr1 plus [p `bind` \_ -> result op | (p,op) <- xs]



-- Informal Grammar
-- expr   ::= factor | factor addop expr
-- addop  ::= '+' | '-'
-- factor ::= nat | '(' expr ')'

expr = factor `chainl1` addop
addop = ops [(char '+', (+)), (char '-', (-))]
factor = nat `plus`  bracket (char '(') expr (char ')')


r0 = expr "1110+12-19"