{-  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 FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Text.GrammarCombinators.Transform.PenalizeErrors where

import Text.GrammarCombinators.Base

import Language.Haskell.TH.Syntax (lift)

import Control.Applicative
import Data.Enumerable

data MaybeSemanticT r ix = JustV { fromJustV :: r ix } | NothingV deriving (Show)

isJustV :: MaybeSemanticT r ix -> Bool
isJustV (JustV _) = True
isJustV NothingV = False
  
newtype PBEHProductionRule p (phi :: * -> *) (unusedR :: * -> *) (r :: * -> *) t v = MkPBEH { unPBEH :: p v }

instance (ProductionRule p) => ProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where
  a >>> b = MkPBEH $ unPBEH a >>> unPBEH b
  a ||| b = MkPBEH $ unPBEH a ||| unPBEH b
  die = MkPBEH die
  endOfInput = MkPBEH endOfInput
 
instance (LiftableProductionRule p) => LiftableProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where
  epsilonL v q = MkPBEH $ epsilonL v q

instance (EpsProductionRule p) =>
         EpsProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) where
  epsilon v = MkPBEH $ epsilon v

instance (RecProductionRule p phi (MaybeSemanticT r), LiftableProductionRule p, PenaltyProductionRule p) =>
         RecProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) phi (MaybeSemanticT r) where
  ref idx = MkPBEH $
            ref idx
        ||| penalty 1 (epsilonL NothingV [| NothingV |])

instance (LoopProductionRule p phi (MaybeSemanticT r), LiftableProductionRule p, PenaltyProductionRule p) =>
         LoopProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) phi (MaybeSemanticT r) where
  manyRef idx = MkPBEH $ manyRef idx 

instance forall p t phi r.
         (PenaltyProductionRule p, LiftableProductionRule p, TokenProductionRule p t, Token t) =>
         TokenProductionRule (PBEHProductionRule p phi (MaybeSemanticT r) r t) t where
  token tt = 
    let 
      altT = head $ enumConcreteTokens tt
    in MkPBEH $     token tt
                ||| penalty 1 (epsilonL altT (lift altT))
                ||| penalty 1 ((altT, lift altT) $|>>* anyToken)
  anyToken =
    let 
      altT :: ConcreteToken t
      altT = head $ enumConcreteTokens $ (head enumerate :: t)
    in MkPBEH $     anyToken
                ||| penalty 1 (epsilonL altT (lift altT))

newtype IsJustApp v = IJA { unIJA :: Bool }

instance Functor IsJustApp where
  fmap _ v = IJA $ unIJA v
instance Applicative IsJustApp where
  pure _ = IJA True
  IJA va <*> IJA vb = IJA $ va && vb

processPenalizedSimple ::
  forall phi r. (HFunctor phi (PF phi)) =>
  Processor phi r -> Processor phi (MaybeSemanticT r)
processPenalizedSimple proc idx pfv = 
  let 
    allJustVs :: phi ix -> PF phi (MaybeSemanticT r) ix -> Bool 
    allJustVs idx' pfv' = unIJA $ hmapA (\_ v -> IJA $ isJustV v) idx' pfv'
    fromJustVs :: phi ix -> PF phi (MaybeSemanticT r) ix -> PF phi r ix
    fromJustVs = hmap (\_ (JustV v) -> v)
  in if allJustVs idx pfv
     then JustV $ proc idx $ fromJustVs idx pfv
     else NothingV

penalizeErrors' :: forall p phi r rr t ix.
                   (forall ix'. phi ix' -> PBEHProductionRule p phi (MaybeSemanticT r) r t (rr ix')) ->
                   phi ix -> p (rr ix)
penalizeErrors' g idx = unPBEH (g idx)

penalizeErrorsE :: 
  forall phi t r rr. (Token t) =>
  GExtendedContextFreeGrammar phi t (MaybeSemanticT r) rr ->
  GPenaltyExtendedContextFreeGrammar phi t (MaybeSemanticT r) rr
penalizeErrorsE g idx = penalizeErrors' g idx

penalizeErrors :: 
  forall phi t r rr. (Token t) =>
  GContextFreeGrammar phi t (MaybeSemanticT r) rr ->
  GPenaltyContextFreeGrammar phi t (MaybeSemanticT r) rr
penalizeErrors g idx = penalizeErrors' g idx