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 (\_ -> fromJustV)
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