content: -- Copyright (c) 1982-1999 Lennart Augustsson, Thomas Johnsson
  -- See LICENSE for the full license.
  --
  -- @@ Higher order functions to make parsers.  A (Parser a b) takes a list of a
  -- @@ and returns a list of possible parsings of this string.  A parsing
  -- @@ consists of a b value, and a list of remaining as.
  
  module Parse(Parser, (+.+), (..+), (+..), (|||), (>>-), (>>>), (||!), (|!!), (.>),
               into, lit, litp, many, many1, succeed, failure, sepBy, count, sepBy1, testp, token, recover,
               ParseResult, parse, sParse, simpleParse) where
  
  -- @@ Parsing combinatores with good error reporting.
  
  infixr 8 +.+ , ..+ , +..
  infix  6 >>- , >>>, `into` , .>
  infixr 4 ||| , ||! , |!!
  
  type PErrMsg = String
  
  data FailAt a
          = FailAt !Int [PErrMsg] a        -- token pos, list of acceptable tokens, rest of tokens
          deriving (Show)
  data ParseResult a b
          = Many [(b, Int, a)] (FailAt a)  -- parse succeeded with many (>1) parses)
          | One b !Int a !(FailAt a)       -- parse succeeded with one parse
          | None !Bool !(FailAt a)         -- parse failed. The Bool indicates hard fail
          deriving (Show)
  
  type Parser a b = a -> Int -> ParseResult a b
  
  noFail :: FailAt a
  noFail = FailAt (-1) [] (error "noFail") -- indicates no failure yet
  
  updFail :: FailAt a -> ParseResult a b -> ParseResult a b
  updFail f (None w f')     = None w (bestFailAt f f')
  updFail f (One c n as f') = One c n as (bestFailAt f f')
  updFail f (Many cas f')   = let r = bestFailAt f f' in seq r (Many cas r)
  
  bestFailAt :: FailAt a -> FailAt a -> FailAt a
  bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) =
          if i > j then
              f
          else if j > i then
              f'
          else if i == -1 then
              noFail
          else
              FailAt i (a ++ a') t
  
  -- Alternative
  (|||) :: Parser a b -> Parser a b -> Parser a b
  p ||| q = \as n ->
      case (p as n, q as n) of
          (pr@(None True  _), _                ) -> pr
          (pr@(None _     f), qr               ) -> updFail f qr
          (    One b k as f , qr               ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr
          (    Many  l f    , qr               ) -> Many (        l++l') (bestFailAt f f') where (l',f') = lf qr
      where lf (Many l f)     = (l,          f)
            lf (One b k as f) = ([(b,k,as)], f)
            lf (None _   f)   = ([],         f)
  
  -- Alternative, but with committed choice
  (||!) :: Parser a b -> Parser a b -> Parser a b
  p ||! q = \as n ->
      case (p as n, q as n) of
          (pr@(None True  _), _                ) -> pr
          (    None _     f , qr               ) -> updFail f qr
          (pr               , _                ) -> pr
  
  processAlts :: FailAt a -> [(b, Int, a)] -> [ParseResult a b] -> ParseResult a b
  processAlts f [] [] = seq f (None False f)
  processAlts f [(b,k,as)]  [] = seq f (One b k as f)
  processAlts f rs [] = seq f (Many rs f)
  processAlts f rs (w@(None True _):_) = seq f w
  processAlts f rs (None False f':rws) = processAlts (bestFailAt f f') rs rws
  processAlts f rs (One b k as f':rws) = processAlts (bestFailAt f f') (rs++[(b,k,as)]) rws
  processAlts f rs (Many rs' f'  :rws) = processAlts (bestFailAt f f') (rs++rs') rws
  
  doMany :: (c -> b) -> [(c, Int, a)] -> FailAt a -> ParseResult a b
  doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f
  
  -- Sequence
  (+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
  p +.+ q =
      \as n->
      case p as n of
          None w f -> None w f
          One b n' as' f ->
              case q as' n' of
                  None w f'         -> None w (bestFailAt f f')
                  One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f')
                  Many cas f'       -> doMany (\x->(b,x)) cas (bestFailAt f f')
          Many bas f ->
              let rss = [ case q as' n' of { None w f -> None w f;
                                             One c n'' as'' f' -> One (b,c) n'' as'' f';
                                             Many cas f' -> doMany (\x->(b,x)) cas f'  }
                          | (b,n',as') <- bas ]
              in  processAlts f [] rss
  
  -- Sequence, throw away first part
  (..+) :: Parser a b -> Parser a c -> Parser a c
  p ..+ q = -- p +.+ q >>- snd
      \as n->
      case p as n of
          None w f       -> None w f
          One _ n' as' f -> updFail f (q as' n')
          Many bas f     -> processAlts f [] [ q as' n' | (_,n',as') <- bas ]
  
  -- Sequence, throw away second part
  (+..) :: Parser a b -> Parser a c -> Parser a b
  p +.. q = -- p +.+ q >>- fst
      \as n->
      case p as n of
          None w f -> None w f
          One b n' as' f ->
              case q as' n' of
                  None w f'         -> None w (bestFailAt f f')
                  One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f')
                  Many cas f'       -> doMany (const b) cas (bestFailAt f f')
          Many bas f ->
              let rss = [ case q as' n' of { None w f -> None w f;
                                             One _ n'' as'' f' -> One b n'' as'' f';
                                             Many cas f' -> doMany (const b) cas f' }
                          | (b,n',as') <- bas ]
              in  processAlts f [] rss
  
  -- Return a fixed value
  (.>) :: Parser a b -> c -> Parser a c
  p .> v =
      \as n->
      case p as n of
        None w f        -> None w f
        One _ n' as' f' -> One v n' as' f'
        Many bas f      -> doMany (const v) bas f
  
  -- Action
  (>>-) :: Parser a b -> (b->c) -> Parser a c
  p >>- f = \as n->
      case p as n of
          None w f       -> None w f
          One b n as' ff -> One (f b) n as' ff
          Many bas ff    -> doMany f bas ff
  
  -- Action on two items
  (>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
  p >>> f = \as n->
      case p as n of
          None w ff          -> None w ff
          One (b,c) n as' ff -> One (f b c) n as' ff
          Many bas ff        -> doMany (\ (x,y)->f x y) bas ff
  
  -- Use value
  into :: Parser a b -> (b -> Parser a c) -> Parser a c
  p `into` fq = \as n ->
      case p as n of
          None w f       -> None w f
          One b n' as' f -> updFail f (fq b as' n')
          Many bas f     -> processAlts f [] [ fq b as' n' | (b,n',as') <- bas ]
  
  -- Succeeds with a value
  succeed :: b -> Parser a b
  succeed v = \as n -> One v n as noFail
  
  -- Always fails.
  failure :: PErrMsg -> Parser a b
  failure s = \as n -> None False (FailAt n [s] as)
  
  -- Fail completely if parsing proceeds a bit and then fails
  mustAll :: Parser a b -> Parser a b
  mustAll p = \as n->
          case p as n of
          None False f@(FailAt x _ _) | x/=n -> None True f
          r -> r
  
  -- If first alternative gives partial parse it's a failure
  (|!!) :: Parser a b -> Parser a b -> Parser a b
  p |!! q = mustAll p ||! q
  
  -- Kleene star
  many :: Parser a b -> Parser a [b]
  many p = p `into` (\v-> many p >>- (v:))
       ||! succeed []
  
  many1 :: Parser a b -> Parser a [b]
  many1 p = p `into` (\v-> many p >>- (v:))
  
  -- Parse an exact number of items
  count :: Parser a b -> Int -> Parser a [b]
  count p 0 = succeed []
  count p k = p +.+ count p (k-1) >>> (:)
  
  -- Non-empty sequence of items separated by something
  sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
  p `sepBy1` q = p `into` (\v-> many (q ..+ p) >>- (v:))
  
  -- Sequence of items separated by something
  sepBy :: Parser a b -> Parser a c -> Parser a [b]
  p `sepBy` q = p `sepBy1` q
            ||! succeed []
  
  -- Recognize a literal token
  lit :: (Eq a, Show a) => a -> Parser [a] a
  lit x = \as n ->
          case as of
          a:as' | a==x -> One a (n+1) as' noFail
          _ -> None False (FailAt n [show x] as)
  
  -- Recognize a token with a predicate
  litp :: PErrMsg -> (a->Bool) -> Parser [a] a
  litp s p = \as n->
          case as of
          a:as' | p a -> One a (n+1) as' noFail
          _ -> None False (FailAt n [s] as)
  
  -- Generic token recognizer
  token :: (a -> Either PErrMsg (b,a)) -> Parser a b
  token f = \as n->
          case f as of
              Left s -> None False (FailAt n [s] as)
              Right (b, as') -> One b (n+1) as' noFail
  
  -- Test a semantic value
  testp :: String -> (b->Bool) -> Parser a b -> Parser a b
  testp s tst p = \ as n ->
      case p as n of
        None w f -> None w f
        o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as)
        Many bas f ->
          case [ r | r@(b, _, _) <- bas, tst b] of
              [] -> None False (FailAt n [s] as)
              [(x,y,z)] -> One x y z f
              rs -> Many rs f
  
  -- Try error recovery.
  recover :: Parser a b -> ([PErrMsg] -> a -> Maybe (a, b)) -> Parser a b
  recover p f = \ as n ->
          case p as n of
              r@(None _ fa@(FailAt n ss ts)) ->
                  case f ss ts of
                      Nothing -> r
                      Just (a, b) -> One b (n+1) a fa
              r -> r
  
  -- Parse, and check if it was ok.
  parse :: Parser a b -> a -> Either ([PErrMsg],a) [(b, a)]
  parse p as =
          case p as 0 of
              None w (FailAt _ ss ts) -> Left (ss,ts)
              One b _ ts _            -> Right [(b,ts)]
              Many bas _              -> Right [(b,ts) | (b,_,ts) <- bas ]
  
  sParse :: (Show a) => Parser [a] b -> [a] -> Either String b
  sParse p as =
          case parse p as of
              Left (ss,ts)     -> Left ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n")
                                    where pshow [] = "<EOF>"
                                          pshow (t:_) = show t
              Right ((b,[]):_)  -> Right b
              Right ((_,t:_):_) -> Left ("Parse failed at token "++show t++", expected <EOF>\n")
              Right ([])        -> error("Parse.hs :: sParse unexpected pattern")
  
  simpleParse :: (Show a) => Parser [a] b -> [a] -> b
  simpleParse p as =
          case sParse p as of
          Left msg -> error msg
          Right x -> x
  