implementation module StdParsComb

// ****************************************************************************************
//	Concurrent Clean Standard Library Module
//	Copyright 1998, 1999, 2002 HILT bv & University of Nijmegen, The Netherlands
// ****************************************************************************************

import StdInt, StdBool, StdOverloaded, StdList, StdFunc, StdString

:: Parser s r :== [s] -> ParsResult s r
:: ParsResult s r :== [([s],r)]

:: CParser s r t :== (SucCont s r t) (XorCont s t) (AltCont s t) -> Parser s t
:: SucCont s r t :== r (XorCont s t) (AltCont s t) -> Parser s t
:: XorCont s t   :== (AltCont s t) -> ParsResult s t
:: AltCont s t   :== ParsResult s t

fail :: CParser s r t
fail = \ sc xc ac ss -> xc ac

yield :: r -> CParser s r t
yield x = \sc -> sc x

cut :: (CParser s r t) -> CParser s r t
cut p = \sc xc ac -> p sc (\ac -> ac) ac

symbol :: s -> CParser s s t | == s
symbol s = psymbol
where
	psymbol sc xc ac [x:ss] | x==s = sc s xc ac ss
	psymbol sc xc ac _             = xc ac

token :: [s] -> CParser s [s] t | ==s
token t = p
where p sc xc ac ss
		| t == head = sc t xc ac tail
		| otherwise = xc ac
		where (head,tail) = splitAt (length t) ss

satisfy :: (s->Bool) -> CParser s s t
satisfy f = p
where
	p sc xc ac [s:ss] | f s = sc s xc ac ss
	p sc xc ac _            = xc ac

eof :: CParser s Int t
eof = p
where p sc xc ac [] = sc 42 xc ac []
      p sc xc ac _  = xc ac

begin :: !(CParser s t t) -> Parser s t
begin p = p (\x xc ac ss -> [(ss,x):xc ac]) (\ac -> ac) []

begin1 :: !(CParser s t t) -> Parser s t
begin1 p = p (\x xc ac ss -> [(ss,x)]) (\ac -> ac) []

(<|>) infixr 4 :: (CParser s r t) (CParser s r t) -> CParser s r t
(<|>) p1 p2 = \sc xc ac ss -> p1 sc (\ac2 -> ac2) (p2 sc xc ac ss) ss

(<!>) infixr 4 :: (CParser s r t) (CParser s r t) -> CParser s r t
(<!>) p1 p2 = \sc xc ac ss -> p1 (\x xc2 -> sc x xc) (\ac3 -> p2 sc xc ac3 ss) ac ss

(<&>) infixr 6 :: (CParser s u t) (u -> CParser s v t) -> CParser s v t
(<&>) p1 p2 = \sc -> p1 (\t -> p2 t sc)

(<&) infixr 6 :: (CParser s u t) (CParser s v t) -> CParser s u t
(<&) p1 p2 = p1 <&> \u -> p2 <@ \_ -> u

(&>) infixr 6 :: (CParser s u t) (CParser s v t) -> CParser s v t
(&>) p1 p2 = p1 <&> \_ -> p2

(<:&>) infixr 6 :: (CParser s u t) (CParser s [u] t) -> CParser s [u] t
(<:&>) p1 p2 = p1 <&> \h -> p2 <@ \t -> [h:t]

(<++>) infixr 6 :: (CParser s [u] t) (CParser s [u] t) -> CParser s [u] t
(<++>) p1 p2 = p1 <&> \l -> p2 <@ \m -> l++m

(<!&>) infixr 6 :: (CParser s u t) (u -> CParser s v t) -> CParser s v t
(<!&>) p1 p2 = \sc -> p1 (\t ac2 -> p2 t sc (\ac -> ac))
// Cut inside <!>, if p1 succeeds, next alt is removed

(<@) infixl 5 :: (CParser s r t) (r->u) -> CParser s u t
(<@) p f = \sc -> p (sc o f)

<*?> :: (CParser s r t) -> CParser s [r] t
<*?> p = (     p       <&> \r  -> 
                <*?> p <@  \rs -> [r:rs])
           <|> yield []

<*> :: (CParser s r t) -> CParser s [r] t
//<*> p = (     p        <!&> \r  -> 
//                 <*> p <@     \rs -> [r:rs])
//          <!> yield []
// code below is semantically equivalent to combinator expression above 
<*> p = ClistP p []

ClistP :: (CParser s r t) [r] -> CParser s [r] t
ClistP p l
// =			(p <!&> \r -> ClistP p [r:l])
//	<!>	yield (reverse l)
// code below is semantically equivalent to combinator expression above 
 = clp l
where
	clp l sc xc ac ss
		=	p
			(\r ac2 -> clp [r:l] (\x xc2 -> sc x xc) (\ac -> ac))
			(\ac3 -> sc (reverse l) xc ac3 ss)
			ac
			ss

<+> :: (CParser s r t) -> CParser s [r] t
//<+> p = p <&> \r -> <*> p <@ \rs -> [r:rs]
// code below is semantically equivalent to combinator expression above 
<+> p = p <&> \r -> ClistP p [r]

<+?> :: (CParser s r t) -> CParser s [r] t
<+?> p = p <&> \r -> <*?> p <@ \rs -> [r:rs]

<?> :: (CParser s r t) -> CParser s [r] t // Eager version, if p succeeds use it!
<?> p = (p <@ \r -> [r]) <!> yield []

<?@> :: (CParser s r t) (r->u) u -> CParser s u t
<?@> p f u = (p <@ \r -> f r) <!> yield u

<??> :: (CParser s r t) -> CParser s [r] t // Lazy version
<??> p = (p <@ \r -> [r]) <|> yield []

<??@> :: (CParser s r t) (r->u) u -> CParser s u t
<??@> p f u = (p <@ \r -> f r) <|> yield u

(>?<) infix 9 :: (CParser s r t) (r -> Bool) -> (CParser s r t) // condition on parsed item
(>?<) p f = \sc -> p (\r xc2 ac2 ss2 -> if (f r) (sc r xc2 ac2 ss2) (xc2 ac2))

(@>) infix 7 :: (r->u) (CParser s r t) -> CParser s u t
(@>) f p = \sc -> p (sc o f)

(+&+) infixl 6 :: (CParser s (u->v) t) (CParser s u t) -> CParser s v t
(+&+) p1 p2 = \sc -> p1 (\f -> p2 (sc o f))

(-&+) infixl 8 :: (CParser s v t) (CParser s u t) -> CParser s u t
(-&+) p1 p2 = \sc -> p1 (\_ -> p2 sc) 

(+&-) infixl 6 :: (CParser s v t) (CParser s u t) -> CParser s v t
(+&-) p1 p2 = \sc -> p1 (\v -> p2 (\_ -> sc v)) 

digit :: CParser Char Int x
digit = satisfy isDigit <@ digitToInt

nat :: CParser Char Int t
nat = <+> digit <@ foldl (\x y -> x*10 + y) 0

int :: CParser Char Int t
int =      symbol '-' <!&> (\_ -> nat <@ ~)
       <!> nat

identifier :: CParser Char String t
identifier = satisfy isAlpha <&> \c -> <*> (satisfy isAlphanum) <@ \r -> toString [c:r]

class isWhite s :: !s -> Bool
instance isWhite Char where isWhite c = isSpace c

sp :: (CParser s r t) -> CParser s r t | isWhite s
sp p = \sc xc ac ss -> p sc xc ac (dropWhile isWhite ss)

spsymbol :: s -> CParser s s t | ==, isWhite s
spsymbol s = sp (symbol s)

sptoken :: [s] -> CParser s [s] t | ==, isWhite s
sptoken t = sp (token t)

parseSequence :: (CParser a b c) (CParser a d c) -> CParser a [b] c
parseSequence p1 p2 = p1 <:&> (<*> (p2 &> p1))
//	accept one or more 'b''s sepparated by 'd''s; accumulate 'b''s in a list

parseChainLeft :: (CParser a b c) (CParser a (b b -> b) c) -> CParser a b c
parseChainLeft p1 p2 = p1 <&> chainl
where
	chainl x =		p2 <&> (\op -> p1 <&> (\y -> chainl (op x y)))
				<!>	yield x
// p1 parses elements that are given to the function found by p2. Left associative.

parseChainRight :: (CParser a b c) (CParser a (b b -> b) c) -> CParser a b c
parseChainRight p1 p2 = p1 <&> chainr
where
	chainr x =		p2 <&> (\op -> p1 <&> (\y -> chainr y <@ op x))
				<!>	yield x
// p1 parses elements that are given to the function found by p2. Right associative.

choice :: ![CParser a b c] -> CParser a b c // Apply the first parser from the list that succeeds
choice l = foldl (<!>) fail l