-- Parsing combinators ==================================================
--
-- Taken from Graham Hutton, Higher-order functions for parsing,
-- Journal of Functional Programming, 2(3):323-343, July 1992.

module

infixr "!!";		-- "or", alternation in BNF
infixr "..";		-- "then", juxtaposition in BNF
infixr "x..";		-- Drop left-hand value
infixr "..x";		-- Drop right-hand value
infixl "$opt";		-- Optional component, [_] in BNF
infixl "$using";	-- Semantic actions
infixl "$return";	-- Constant result value

export	succeed, fail, satisfy, literal, string,	-- Primitives
	(!!), (..), $opt, many, some,			-- Combinators
	$using, (x..), (..x), $return,			-- Values
	number, word, any, nibble, symbol;              -- Useful


-- Auxilliary Definitions ===============================================
--
-- cons  :: (*a # List *a) -> List *a
-- foldr :: (*a -> *b -> *b) -> *b -> List *a -> *b
--
-- type Parser *a *b == List *a -> List (*b # List *a)

rec	cons (x,xs) = x.xs

and	foldr op a []     = a
||	foldr op a (x.xs) = op x (foldr op a xs)


-- Primitive Parsers ====================================================
--
-- succeed :: *b -> Parser *a *b
-- fail    :: Parser *a *b
-- satisfy :: (*a -> Bool) -> Parser *a *a
-- literal :: *a -> Parser (pos *a) *a
-- string  :: List *a -> Parser *a (List *a)

and	succeed v = \inp . [(v,inp)]

and	fail = \inp . []

and	satisfy p []     = fail []
||	satisfy p (x.xs) = if (p x) then (succeed x xs) else (fail xs)

and	literal x = satisfy (=x)

and	string []     = succeed []
||	string (x.xs) = (literal x .. string xs) $using cons


-- Combinators ==========================================================
--
-- (!!) :: Parser *a *b -> Parser *a *b -> Parser *a *b
-- (..) :: Parser *a *b -> Parser *a *c -> Parser *a (*b # *c)
-- $opt :: Parser *a *b -> *b -> Parser *a *b
-- many :: Parser *a *b -> Parser *a (List *b)
-- some :: Parser *a *b -> Parser *a (List *b)

and	p1 !! p2 = \inp . p1 inp @ p2 inp

and	p1 .. p2 = \inp . [((v1,v2),out2) ;; (v1,out1) <- p1 inp ;
                                             (v2,out2) <- p2 out1]

and	p $opt v = \inp . let (v',out) = hd ((p !! succeed v) inp)
	                  in  [(v',out)]

and	many p = ((p .. many p) $using cons) $opt []

and	some p = (p .. many p) $using cons


-- Manipulating Values ==================================================
--
-- $using  :: Parser *a *b -> (*b -> *c) -> Parser *a *c
-- (x..)   :: Parser *a *b -> Parser *a *c -> Parser *a *c
-- (..x)   :: Parser *a *b -> Parser *a *c -> Parser *a *b
-- $return :: Parser *a *b -> *c -> Parser *a *c

and	p $using f = \inp . [(f v,out) ;; (v,out) <- p inp]

and	p1 x.. p2 = (p1 .. p2) $using snd

and	p1 ..x p2 = (p1 .. p2) $using fst

and	p $return v = p $using (\x.v)


-- Useful Parsers =======================================================
--
-- number :: Parser Char (List Char)
-- word   :: Parser Char (List Char)
-- any    :: (*a -> Parser *b *c) -> (List *a) -> Parser *b *c
-- nibble :: Parser Char *a -> Parser Char *a
-- symbol :: (List Char) -> Parser Char (List Char)

and	number = some (satisfy isdigit)

and	word = some (satisfy isalpha)

and	any p = foldr ((!!) o p) fail

and	nibble p = let white = many (any literal " \t\n")
	           in white x.. p ..x white

and	symbol = nibble o string

end

-- ======================================================================