{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, TypeOperators, UndecidableInstances #-}
-- | Packrat parser
module Text.Grampa.PEG.Packrat (Parser(..), Result(..)) where

import Control.Applicative (Applicative(..), Alternative(..), liftA2)
import Control.Monad (Monad(..), MonadPlus(..))
#if MIN_VERSION_base(4,13,0)
import Control.Monad (MonadFail(fail))
#endif

import Data.Functor.Classes (Show1(..))
import Data.Functor.Compose (Compose(..))
import Data.Monoid (Monoid(mappend, mempty))
import Data.Monoid.Factorial(FactorialMonoid)
import Data.Monoid.Textual(TextualMonoid)
import Data.Ord (Down(Down))
import Data.Semigroup (Semigroup(..))
import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf))
import Data.String (fromString)
import Debug.Trace (trace)
import Witherable (Filterable(mapMaybe))

import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Null as Null
import qualified Data.Monoid.Textual as Textual

import qualified Rank2

import qualified Text.Parser.Char
import Text.Parser.Char (CharParsing)
import Text.Parser.Combinators (Parsing(..))
import Text.Parser.LookAhead (LookAheadParsing(..))
import Text.Parser.Input.Position (fromEnd)
import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),
                          InputParsing(..), InputCharParsing(..),
                          GrammarParsing(..), MultiParsing(..),
                          TailsParsing(parseTails), ParseResults, ParseFailure(..), Pos)
import Text.Grampa.Internal (emptyFailure, erroneous, expected, expectedInput, replaceExpected, noFailure,
                             TraceableParsing(..))

data Result g s v = Parsed{parsedPrefix :: !v, 
                           parsedSuffix :: ![(s, g (Result g s))]}
                  | NoParse {-# UNPACK #-} !(ParseFailure Pos s)

-- | Parser type for Parsing Expression Grammars that uses an improved packrat algorithm, with O(1) performance bounds
-- but with worse constants and more memory consumption than the backtracking 'Text.Grampa.PEG.Backtrack.Parser'. The
-- 'parse' function returns an input prefix parse paired with the remaining input suffix.
newtype Parser g s r = Parser{applyParser :: [(s, g (Result g s))] -> Result g s r}

instance Show s => Show1 (Result g s) where
   liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest
   liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest

instance Functor (Result g s) where
   fmap f (Parsed a rest) = Parsed (f a) rest
   fmap _ (NoParse failure) = NoParse failure

instance Filterable (Result g s) where
   mapMaybe f (Parsed a rest) =
      maybe (NoParse $ expected (fromEnd $ Factorial.length rest) "filter") (`Parsed` rest) (f a)
   mapMaybe _ (NoParse failure) = NoParse failure
   
instance Functor (Parser g s) where
   fmap f (Parser p) = Parser (fmap f . p)

instance Applicative (Parser g s) where
   pure a = Parser (Parsed a)
   Parser p <*> Parser q = Parser r where
      r rest = case p rest
               of Parsed f rest' -> f <$> q rest'
                  NoParse failure -> NoParse failure

instance Alternative (Parser g s) where
   empty = Parser (NoParse . emptyFailure . Down . length)
   Parser p <|> Parser q = Parser r where
      r rest = case p rest
               of x@Parsed{} -> x
                  NoParse{} -> q rest
   
instance Filterable (Parser g s) where
   mapMaybe f (Parser p) = Parser (mapMaybe f . p)
   {-# INLINABLE mapMaybe #-}

instance Monad (Parser g s) where
   return = pure
   Parser p >>= f = Parser r where
      r rest = case p rest
               of Parsed a rest' -> applyParser (f a) rest'
                  NoParse failure -> NoParse failure

#if MIN_VERSION_base(4,13,0)
instance MonadFail (Parser g s) where
#endif
   fail msg = Parser (\rest-> NoParse $ erroneous (Down $ length rest) msg)

instance MonadPlus (Parser g s) where
   mzero = empty
   mplus = (<|>)

instance Semigroup x => Semigroup (Parser g s x) where
   (<>) = liftA2 (<>)

instance Monoid x => Monoid (Parser g s x) where
   mempty = pure mempty
   mappend = (<>)

instance FactorialMonoid s => Parsing (Parser g s) where
   try (Parser p) = Parser q
      where q rest = rewindFailure (p rest)
               where rewindFailure NoParse{} = NoParse (emptyFailure $ fromEnd $ length rest)
                     rewindFailure parsed = parsed
   Parser p <?> msg  = Parser q
      where q rest = replaceFailure (p rest)
               where replaceFailure (NoParse f) = NoParse (replaceExpected (fromEnd $ Factorial.length rest) msg f)
                     replaceFailure parsed = parsed
   eof = Parser p
      where p rest@((s, _) : _)
               | not (Null.null s) = NoParse (expected (Down $ length rest) "end of input")
            p rest = Parsed () rest
   unexpected msg = Parser (\t-> NoParse $ erroneous (Down $ length t) msg)
   notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))
      where rewind t Parsed{} = NoParse (expected (Down $ length t) "notFollowedBy")
            rewind t NoParse{} = Parsed () t

instance FactorialMonoid s => CommittedParsing (Parser g s) where
   type CommittedResults (Parser g s) = ParseResults s
   commit (Parser p) = Parser q
      where q rest = case p rest
                     of NoParse failure -> Parsed (Left failure) rest
                        Parsed a rest' -> Parsed (Right a) rest'
   admit (Parser p) = Parser q
      where q rest = case p rest
                     of NoParse failure -> NoParse failure
                        Parsed (Left failure) _ -> NoParse failure
                        Parsed (Right a) rest' -> Parsed a rest'

-- | Every PEG parser is deterministic all the time.
instance FactorialMonoid s => DeterministicParsing (Parser g s) where
   (<<|>) = (<|>)
   takeSome = some
   takeMany = many
   skipAll = skipMany

instance FactorialMonoid s => LookAheadParsing (Parser g s) where
   lookAhead (Parser p) = Parser (\input-> rewind input (p input))
      where rewind t (Parsed r _) = Parsed r t
            rewind _ r@NoParse{} = r

instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where
   satisfy predicate = Parser p
      where p rest@((s, _):t) =
               case Textual.characterPrefix s
               of Just first | predicate first -> Parsed first t
                  _ -> NoParse (expected (Down $ length rest) "Char.satisfy")
            p [] = NoParse (expected 0 "Char.satisfy")
   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)
   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)

-- | Packrat parser
instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where
   type ParserGrammar (Parser g s) = g
   type GrammarFunctor (Parser g s) = Result g s
   parsingResult = const fromResult
   nonTerminal f = Parser p where
      p ((_, d) : _) = f d
      p _ = NoParse (expected 0 "NonTerminal at endOfInput")
   chainRecursive = chainLongestRecursive
   chainLongestRecursive assign (Parser base) (Parser recurse) = Parser q
      where q [] = base []
            q ((s, d):t) = case base initialInput
                           of r@NoParse{} -> r
                              r -> iter r
               where iter r = case recurse ((s, assign r d) : t)
                              of NoParse{} -> r
                                 r'@Parsed{} -> iter r'
                     initialInput = (s, assign (NoParse noFailure) d) : t

instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where
   parseTails = applyParser

instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where
   type ParserInput (Parser g s) = s
   getInput = Parser p
      where p rest@((s, _):_) = Parsed s rest
            p [] = Parsed mempty []
   anyToken = Parser p
      where p rest@((s, _):t) = case Factorial.splitPrimePrefix s
                                of Just (first, _) -> Parsed first t
                                   _ -> NoParse (expected (Down $ length rest) "anyToken")
            p [] = NoParse (expected 0 "anyToken")
   satisfy predicate = Parser p
      where p rest@((s, _):t) =
               case Factorial.splitPrimePrefix s
               of Just (first, _) | predicate first -> Parsed first t
                  _ -> NoParse (expected (Down $ length rest) "satisfy")
            p [] = NoParse (expected 0 "satisfy")
   notSatisfy predicate = Parser p
      where p rest@((s, _):_)
               | Just (first, _) <- Factorial.splitPrimePrefix s, 
                 predicate first = NoParse (expected (Down $ length rest) "notSatisfy")
            p rest = Parsed () rest
   scan s0 f = Parser (p s0)
      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)
               where (prefix, _, _) = Factorial.spanMaybe' s f i
            p _ [] = Parsed mempty []
   takeWhile predicate = Parser p
      where p rest@((s, _) : _)
               | x <- Factorial.takeWhile predicate s = Parsed x (Factorial.drop (Factorial.length x) rest)
            p [] = Parsed mempty []
   take n = Parser p
      where p rest@((s, _) : _)
               | x <- Factorial.take n s, Factorial.length x == n = Parsed x (drop n rest)
            p [] | n == 0 = Parsed mempty []
            p rest = NoParse (expected (Down $ length rest) $ "take " ++ show n)
   takeWhile1 predicate = Parser p
      where p rest@((s, _) : _)
               | x <- Factorial.takeWhile predicate s, not (Null.null x) =
                    Parsed x (Factorial.drop (Factorial.length x) rest)
            p rest = NoParse (expected (Down $ length rest) "takeWhile1")
   string s = Parser p where
      p rest@((s', _) : _)
         | s `isPrefixOf` s' = Parsed s (Factorial.drop (Factorial.length s) rest)
      p rest = NoParse (expectedInput (fromEnd $ length rest) s)

instance (InputParsing (Parser g s), FactorialMonoid s)  => TraceableParsing (Parser g s) where
   traceInput description (Parser p) = Parser q
      where q rest
              | let input = case rest
                            of ((s, _):_) -> s
                               [] -> mempty
                    traceWith prefix = trace (prefix <> description input)
              = case traceWith "Parsing " (p rest)
                  of r@Parsed{}
                        | let prefix = Factorial.take (Factorial.length input - Factorial.length (parsedSuffix r)) input
                        -> trace ("Parsed " <> description prefix) r
                     r@NoParse{} -> traceWith "Failed " r

instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where
   satisfyCharInput predicate = Parser p
      where p rest@((s, _):t) =
               case Textual.characterPrefix s
               of Just first | predicate first -> Parsed (Factorial.primePrefix s) t
                  _ -> NoParse (expected (Down $ length rest) "satisfyCharInput")
            p [] = NoParse (expected 0 "satisfyCharInput")
   notSatisfyChar predicate = Parser p
      where p rest@((s, _):_)
               | Just first <- Textual.characterPrefix s, 
                 predicate first = NoParse (expected (Down $ length rest) "notSatisfyChar")
            p rest = Parsed () rest
   scanChars s0 f = Parser (p s0)
      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)
               where (prefix, _, _) = Textual.spanMaybe_' s f i
            p _ [] = Parsed mempty []
   takeCharsWhile predicate = Parser p
      where p rest@((s, _) : _)
               | x <- Textual.takeWhile_ False predicate s =
                    Parsed x (Factorial.drop (Factorial.length x) rest)
            p [] = Parsed mempty []
   takeCharsWhile1 predicate = Parser p
      where p rest@((s, _) : _)
               | x <- Textual.takeWhile_ False predicate s, not (Null.null x) =
                    Parsed x (drop (Factorial.length x) rest)
            p rest = NoParse (expected (Down $ length rest) "takeCharsWhile1")

-- | Packrat parser
--
-- @
-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>
--                  g (Packrat.'Parser' g s) -> s -> g ('ParseResults' s)
-- @
instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where
   type ResultFunctor (Parser g s) = ParseResults s
   type GrammarConstraint (Parser g s) g' = (g ~ g', Rank2.Functor g)
   {-# NOINLINE parsePrefix #-}
   parsePrefix g input = Rank2.fmap (Compose . fromResult) (snd $ head $ parseGrammarTails g input)
   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult)
                                      (snd $ head $ reparseTails close $ parseGrammarTails g input)
      where close = Rank2.fmap (<* eof) g

parseGrammarTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (Result g s))]
parseGrammarTails g input = foldr parseTail [] (Factorial.tails input)
      where parseTail s parsedTail = parsed where
               parsed = (s,d):parsedTail
               d      = Rank2.fmap (($ parsed) . applyParser) g

reparseTails :: Rank2.Functor g => g (Parser g s) -> [(s, g (Result g s))] -> [(s, g (Result g s))]
reparseTails _ [] = []
reparseTails final parsed@((s, _):_) = (s, gd):parsed
   where gd = Rank2.fmap (`applyParser` parsed) final

fromResult :: (Eq s, Monoid s) => Result g s r -> ParseResults s (s, r)
fromResult (NoParse (ParseFailure pos positive negative)) = Left (ParseFailure (pos - 1) positive negative)
fromResult (Parsed prefix []) = Right (mempty, prefix)
fromResult (Parsed prefix ((s, _):_)) = Right (s, prefix)