{-# LANGUAGE TypeFamilies, FlexibleContexts, RankNTypes #-}

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

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

-- | A parser with underlying parser @p@, unit type @v@ and result type @a@.
newtype TreeParser p v a = TreeParser (p ([ParseTree (Input p) v], a))

-- | An applicative tree parser polymorphic in its underlying parser.
type TreeParserA s v a = forall p. (Parser p, Alternative p, Input p ~ s) => TreeParser p v a

-- | A monadic tree parser polymorphic in its underlying parser.
type TreeParserM s v a = forall p. (Parser p, MonadPlus p, Input p ~ s) => TreeParser p v a

instance Functor p => Functor (TreeParser p v) where
  fmap f (TreeParser p) = TreeParser $ fmap (id *** f) p

instance Applicative p => Applicative (TreeParser p v) where
  pure v = TreeParser $ pure ([], v)
  TreeParser p <*> TreeParser q = TreeParser $
    (\(ts, f) (ts', v) -> (ts ++ ts', f v)) <$> p <*> q

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

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

instance MonadPlus p => MonadPlus (TreeParser p v) where
  mzero = TreeParser mzero
  TreeParser p `mplus` TreeParser q = TreeParser (p `mplus` q)

instance Parser p => Parser (TreeParser p v) where
  type Input (TreeParser p v) = Input p
  type ParseResult (TreeParser p v) = ParseResult p
  satisfy   = treeSatisfy
  runParser = runTreeParser

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

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

-- | Synonym for 'unitBy' 'id'.
unit :: Functor p => TreeParser p v v -> TreeParser p v v
unit = unitBy id

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

-- | Runs the parser and yields the parse tree that has been built so far.
getTree :: Functor p => TreeParser p v a -> TreeParser p v (ParseTree (Input p) v)
getTree (TreeParser p) = TreeParser $ (\(ts, _) -> (ts, branch ts)) `fmap` 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 (B.SucParser s) v a -> TreeParser (B.SucParser t) v 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')