{-# LANGUAGE TypeFamilies #-}

-- |
-- A parser that builds on top of "SucParser" and constructs a full parse tree on success.
module TreeParser (
  TreeParser, treeSatisfy, runTreeParser, unit, getTree, mapInput
  ) where

import qualified SucParser as B
import ParseTree
import Control.Applicative
import Control.Monad.State
import ParserClass

newtype TreeParser v s a = TreeParser (B.SucParser s ([ParseTree s v], a))

instance Functor (TreeParser v s) where
  fmap = liftM

instance Applicative (TreeParser v s) where
  pure  = return
  (<*>) = ap

instance Alternative (TreeParser v s) where
  empty = TreeParser empty
  TreeParser p <|> TreeParser q = TreeParser $ p <|> q

instance Monad (TreeParser v s) where
  return v = TreeParser $ return ([], v)
  TreeParser pv >>= f = TreeParser $ do
    (ts, v) <- pv
    let TreeParser q = f v
    (us, w) <- q
    return (ts ++ us, w)

instance Parser (TreeParser v s) where
  type Input (TreeParser v s) = s
  type ParseResult (TreeParser v s) = Maybe
  satisfy   = treeSatisfy
  runParser = runTreeParser

-- | Recognise a symbol matching a predicate.
treeSatisfy :: (s -> Bool) -> TreeParser v s s
treeSatisfy pred = TreeParser $ (\s -> ([Symbol s], s)) <$> satisfy pred

-- | Runs a parser on the given input, yielding a result on success.
runTreeParser :: TreeParser v s a -> [s] -> Maybe a
runTreeParser (TreeParser p) xs = snd `fmap` runParser p xs

-- | Promotes a parser to a unit parser using the given conversion function. Every sentence recognised by a unit parser counts as a valid selection.
unit :: TreeParser v s v -> TreeParser v s v
unit (TreeParser p) = TreeParser $ (\(ts, v) -> ([Unit v (branch ts)], v)) <$> p

-- | Yields the parse tree that has been built so far.
getTree :: TreeParser v s a -> TreeParser v s (ParseTree s v)
getTree (TreeParser p) = TreeParser $ (\(ts, _) -> (ts, branch ts)) <$> p

-- | If @t@'s can be converted to @s@'s, then a parser that consumes @s@'s can be converted to a parser that consumes @t@'s.
mapInput :: (t -> s) -> TreeParser v s a -> TreeParser v t a
mapInput f (TreeParser p) = TreeParser (B.fromFunction doMapInput) where
  doMapInput input = do  -- note: list monad
    ((trees, value), _) <- B.toFunction p (map f input)
    let (trees', rest') = overwriteManySymbols input trees
    return ((trees', value), rest')