{-  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 KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Compatibility component for the Parsec library.
module Text.GrammarCombinators.Transform.IntroduceBias (
    introduceBias
  , introduceBiasE
  , introduceBiasLE
  ) where

import Prelude hiding (null)

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.CalcFirst

import Data.Set (intersection, null)

data IBW p phi (r :: * -> *) t rr v = MkIBW { 
  firstSetRule :: FSCalculator phi r t rr v,
  unWrap :: FirstSetGrammar phi r t rr -> p v 
  }

ambiguous :: (Token t) => FirstSet t -> FirstSet t -> Bool
ambiguous fsa fsb = (canBeEmpty fsa && canBeEmpty fsb) ||
                    (canBeEOI fsa && canBeEmpty fsb)

mutuallyExclusive :: Token t => FirstSet t -> FirstSet t -> Bool
mutuallyExclusive fsa fsb =  
  null $ firstSet fsa `intersection` firstSet fsb

instance (Token t, ProductionRule p, BiasedProductionRule p) => 
         ProductionRule (IBW p phi r t rr) where
  (a :: IBW p phi r t rr (va -> vb)) >>> (b :: IBW p phi r t rr va) = 
    let fs = firstSetRule a >>> firstSetRule b
        up :: FirstSetGrammar phi r t rr -> p vb 
        up fsg = unWrap a fsg >>> unWrap b fsg
    in MkIBW fs up
  die = MkIBW die (const die)
  endOfInput = MkIBW endOfInput (const endOfInput)
  a ||| (b :: IBW p phi r t rr v) =
    let fs = firstSetRule a ||| firstSetRule b
        fsa :: FirstSetGrammar phi r t rr -> FirstSet t
        fsa = calcFS (firstSetRule a) 
        fsb :: FirstSetGrammar phi r t rr -> FirstSet t
        fsb = calcFS (firstSetRule b) 
        up :: FirstSetGrammar phi r t rr -> p v
        up fsg = if ambiguous (fsa fsg) (fsb fsg)
                 then error "can't introduce bias in ambiguous grammars"
                 else if mutuallyExclusive (fsa fsg) (fsb fsg)
                      then unWrap a fsg >||| unWrap b fsg
                      else unWrap a fsg ||| unWrap b fsg
    in MkIBW fs up

instance (Token t, LiftableProductionRule p, BiasedProductionRule p) =>
         LiftableProductionRule (IBW p phi r t rr) where
  epsilonL v q = MkIBW (epsilonL v q) (\_ -> epsilonL v q) 

instance (Token t, EpsProductionRule p, BiasedProductionRule p) =>
         EpsProductionRule (IBW p phi r t rr) where
  epsilon v = MkIBW (epsilon v) (\_ -> epsilon v) 

instance (Token t, TokenProductionRule p t) => 
         TokenProductionRule (IBW p phi r t rr) t where
  token tt = MkIBW (token tt) (\_ -> token tt)
  anyToken = MkIBW anyToken (const anyToken)
   
instance (Token t, EqFam phi, RecProductionRule p phi r) =>
         RecProductionRule (IBW p phi r t rr) phi r where
  ref idx = MkIBW (ref idx) (\_ -> ref idx)

instance (Token t, EqFam phi, BiasedProductionRule p,
          LiftableProductionRule p, 
          LoopProductionRule p phi r) =>
         LoopProductionRule (IBW p phi r t rr) phi r where
  manyRef idx = MkIBW (manyRef idx) (\_ -> manyRef idx)
  many1Ref idx = MkIBW (many1Ref idx) (\_ -> many1Ref idx)

introduceBias :: (Token t, EqFam phi) =>
                 ProcessingContextFreeGrammar phi t r ->
                 ProcessingBiasedContextFreeGrammar phi t r 
introduceBias gram idx = unWrap (gram idx) gram

introduceBiasE :: (Token t, EqFam phi) =>
                 ProcessingExtendedContextFreeGrammar phi t r ->
                 ProcessingBiasedExtendedContextFreeGrammar phi t r 
introduceBiasE gram idx = unWrap (gram idx) gram

introduceBiasLE :: (Token t, EqFam phi) =>
                 ProcessingLExtendedContextFreeGrammar phi t r ->
                 ProcessingLBiasedExtendedContextFreeGrammar phi t r 
introduceBiasLE gram idx = unWrap (gram idx) gram

-- parseParsecBiased  :: forall phi t r ix.
--                       (Token t, EqFam phi) =>
--                       ProcessingContextFreeGrammar phi t r ->
--                       phi ix -> SourceName -> 
--                       [ConcreteToken t] -> Either ParseError (r ix)
-- parseParsecBiased gram idx = 
--   let irule :: WrapGenParser t (r ix)
--       irule = unWrap (unfoldRecursion gram idx) gram
--       parser = unWGP irule
--   in Parsec.parse parser