module Text.GrammarCombinators.Transform.FoldLoops (
FLBaseIx, FLManyIx,
Memo (FLM),
FoldLoopsDomain (FLBase, FLMany),
FoldLoopsValue (..),
FoldLoopsResultValue (..),
processFoldLoops,
foldLoops,
foldAndProcessLoops
) where
import Text.GrammarCombinators.Base
data FLBaseIx ix
data FLManyIx ix
data FoldLoopsDomain phi ix where
FLBase :: phi ix -> FoldLoopsDomain phi (FLBaseIx ix)
FLMany :: phi ix -> FoldLoopsDomain phi (FLManyIx ix)
instance (FoldFam phi) => FoldFam (FoldLoopsDomain phi) where
foldFam f n =
foldFam (f . FLMany) $
foldFam (f . FLBase) n
instance (ShowFam phi) => ShowFam (FoldLoopsDomain phi) where
showIdx (FLBase idx) = showIdx idx
showIdx (FLMany idx) = showIdx idx ++ "*"
instance (EqFam phi) => EqFam (FoldLoopsDomain phi) where
overrideIdx f (FLBase idx) v (FLBase idx') = unSubVal $ overrideIdx (MkSubVal . f . FLBase) idx (MkSubVal v) idx'
overrideIdx f (FLMany idx) v (FLMany idx') = unSubVal $ overrideIdx (MkSubVal . f . FLMany) idx (MkSubVal v) idx'
overrideIdx f _ _ idx = f idx
instance DomainMap (FoldLoopsDomain phi) phi FLBaseIx where
supIx = FLBase
subIx (FLBase idx) = idx
instance DomainMap (FoldLoopsDomain phi) phi FLManyIx where
supIx = FLMany
subIx (FLMany idx) = idx
instance (MemoFam phi) => MemoFam (FoldLoopsDomain phi) where
data Memo (FoldLoopsDomain phi) v = FLM (Memo phi (SubVal FLBaseIx v)) (Memo phi (SubVal FLManyIx v))
fromMemo (FLM mb _) (FLBase idx) = unSubVal $ fromMemo mb idx
fromMemo (FLM _ mm) (FLMany idx) = unSubVal $ fromMemo mm idx
toMemo f = FLM (toMemo $ MkSubVal . f . FLBase) (toMemo $ MkSubVal . f . FLMany)
instance Domain phi => Domain (FoldLoopsDomain phi)
data family FoldLoopsValue (r :: * -> *) ix
newtype instance FoldLoopsValue r (FLBaseIx ix) = FLBV { unFLBV :: r ix } deriving (Show)
newtype instance FoldLoopsValue r (FLManyIx ix) = FLMV { unFLMV :: [r ix] } deriving (Show)
data family FoldLoopsResultValue (r :: * -> *) (rr :: * -> *) ix
newtype instance FoldLoopsResultValue r rr (FLBaseIx ix) = FLRBV { unFLRBV :: rr ix }
newtype instance FoldLoopsResultValue r rr (FLManyIx ix) = FLRMV { unFLRMV :: [r ix] }
data FLWrap p unused1 unused2 phi r t v where
FLW :: p v -> FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v
unFLW :: FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t v -> p v
unFLW (FLW p) = p
instance (ProductionRule p) =>
ProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
(FLW a) >>> (FLW b) = FLW $ a >>> b
(FLW a) ||| (FLW b) = FLW $ a ||| b
die = FLW die
endOfInput = FLW endOfInput
instance (EpsProductionRule p) =>
EpsProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
epsilon = FLW . epsilon
instance (LiftableProductionRule p) =>
LiftableProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) where
epsilonL v q = FLW $ epsilonL v q
instance (TokenProductionRule p t) =>
TokenProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) t where
token = FLW . token
anyToken = FLW anyToken
instance (RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r),
ProductionRule p, EpsProductionRule p) =>
RecProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where
ref idx = FLW $ epsilon (\(FLBV v) -> v) >>> ref (FLBase idx)
instance (ProductionRule p, EpsProductionRule p, LiftableProductionRule p,
TokenProductionRule p t, RecProductionRule p (FoldLoopsDomain phi) (FoldLoopsValue r)) =>
LoopProductionRule (FLWrap p (FoldLoopsDomain phi) (FoldLoopsValue r) phi r t) phi r where
manyRef idx = FLW $ epsilon (\(FLMV lv) -> lv) >>> ref (FLMany idx)
processFoldLoops :: forall phi r rr. GProcessor phi r rr -> GProcessor (FoldLoopsDomain phi) (FoldLoopsValue r) (FoldLoopsResultValue r rr)
processFoldLoops proc (FLBase (idx :: phi ix')) (FLRBV v) = FLBV $ proc idx v
processFoldLoops _ (FLMany _) (FLRMV vs) = FLMV vs
foldLoops ::
GExtendedContextFreeGrammar phi t r rr ->
GContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r) (FoldLoopsResultValue r rr)
foldLoops bgram (FLBase (idx :: phi ix)) =
epsilon FLRBV >>> unFLW (bgram idx)
foldLoops _ (FLMany idx) =
epsilon (\(FLBV v) (FLMV vs) -> FLRMV (v:vs)) >>>
ref (FLBase idx) >>> ref (FLMany idx)
||| epsilon (FLRMV [])
foldAndProcessLoops ::
forall phi t r . Token t =>
ProcessingExtendedContextFreeGrammar phi t r->
ProcessingContextFreeGrammar (FoldLoopsDomain phi) t (FoldLoopsValue r)
foldAndProcessLoops gram =
let loopsproc :: FoldLoopsDomain phi ix -> FoldLoopsResultValue r r ix -> FoldLoopsValue r ix
loopsproc = processFoldLoops identityProcessor
in applyProcessor (foldLoops gram) loopsproc