{-  Copyright 2010 Dominique Devriese

    This file is part of the grammar-combinators library.

    The grammar-combinators library is free software: you can
    redistribute it and/or modify it under the terms of the GNU
    Lesser General Public License as published by the Free
    Software Foundation, either version 3 of the License, or (at
    your option) any later version.

    Foobar is distributed in the hope that it will be useful, but
    WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General
    Public License along with Foobar. If not, see
    <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}

module Text.GrammarCombinators.Parser.PenaltyParser where

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Transform.UnfoldRecursion
import Text.GrammarCombinators.Transform.UnfoldLoops

import Control.Monad.State
import Control.Applicative

import Data.Tuple.HT(mapFst, mapSnd)
import Data.Monoid
import Data.InfinitePriorityQueue (InfPQ, increasePriorities)
import qualified Data.InfinitePriorityQueue as IPQ

data PenaltyParserState t v = FullParse { unFullParse :: v }
                            | PartialParse { unPartialParse :: ConcreteToken t -> PenaltyParserRule t v }
data PenaltyParserRule t v = PPR { unPPR :: InfPQ (PenaltyParserState t v) }

seqState (PPR r) s = PPR $ fmap (<*> s) r

instance Functor (PenaltyParserState t) where
  fmap f (FullParse v) = FullParse (f v)
  fmap f (PartialParse c) = PartialParse (fmap f . c)

instance Applicative (PenaltyParserState t) where 
  pure = FullParse
  (FullParse f) <*> r = fmap f r
  (PartialParse cf) <*> rs = PartialParse $ \t -> seqState (cf t) rs

instance Functor (PenaltyParserRule t) where
  fmap f (PPR q) = PPR $ fmap (fmap f) q 

instance Applicative (PenaltyParserRule t) where
  (PPR fq) <*> r@(PPR rq) = PPR $ do fs <- fq
                                     case fs of 
                                       FullParse f -> unPPR $ fmap f r
                                       PartialParse c -> return $ PartialParse $ \t -> c t <*> r
  pure v = PPR $ pure $ pure v

instance Alternative (PenaltyParserRule t) where
  empty = PPR empty
  qa <|> qb = PPR $ unPPR qa <|> unPPR qb 

instance ProductionRule (PenaltyParserRule t) where
  (>>>) = (<*>)
  (|||) = (<|>)
  die = empty
  endOfInput = undefined
  
instance EpsProductionRule (PenaltyParserRule t) where
  epsilon = pure

instance LiftableProductionRule (PenaltyParserRule t) where
  epsilonL v _ = epsilon v

instance (Token t) => TokenProductionRule (PenaltyParserRule t) t where
  token tt =
    let tst = PPR $ pure $ PartialParse handleToken
        handleToken t | classify t == tt = epsilon t
        handleToken t | otherwise = empty 
    in tst
  anyToken = PPR $ pure $ PartialParse epsilon

instance PenaltyProductionRule (PenaltyParserRule t) where
  penalty p (PPR q) = PPR $ increasePriorities p q

parsePenaltyRuleQ :: Int -> InfPQ (PenaltyParserState t v) -> 
                   [ConcreteToken t] -> [(Int, v)]
parsePenaltyRuleQ lim q (t:ts') = parsePenaltyRuleQ lim nq ts'
  where nq = do PartialParse f <- q 
                unPPR (f t)
parsePenaltyRuleQ lim q [] = [(p,v) | (p, FullParse v) <- IPQ.toAscList lim q]

parsePenaltyRule :: PenaltyParserRule t v -> Int -> [ConcreteToken t] -> [(Int,v)]
parsePenaltyRule rule lim ts = 
  let startqueue = unPPR rule 
  in parsePenaltyRuleQ lim startqueue ts

parsePenaltyR :: (Token t) => ProcessingPenaltyRegularGrammar phi t r -> phi ix -> Int -> [ConcreteToken t] -> [(Int, r ix)]
parsePenaltyR gram idx = parsePenaltyRule (gram idx)

parsePenalty :: (Token t) => ProcessingPenaltyContextFreeGrammar phi t r -> phi ix -> Int -> [ConcreteToken t] -> [(Int, r ix)]
parsePenalty gram = parsePenaltyR (unfoldRecursionP gram)

parsePenaltyE :: (Token t) => ProcessingPenaltyExtendedContextFreeGrammar phi t r -> phi ix -> Int -> [ConcreteToken t] -> [(Int, r ix)]
parsePenaltyE gram = parsePenalty (unfoldLoopsP gram)