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