module Text.GrammarCombinators.Parser.Packrat (
Result (Parsed, NoParse),
Derivs,
parsePackrat
) where
import Text.GrammarCombinators.Base
data Result phi r t v = Parsed v (Derivs phi r t) |
NoParse
instance (Show v) => Show (Result phi r t v) where
show (Parsed v _) = "Parsed " ++ show v ++ " _"
show NoParse = "NoParse"
instance Functor (Result phi r t) where
fmap f (Parsed v d) = Parsed (f v) d
fmap _ NoParse = NoParse
data PRPrimTokenIx
data PREndOfInputIx
data PRBaseIx ix
data PackratDomain phi ix where
PackratDomainBase :: phi ix -> PackratDomain phi (PRBaseIx ix)
PackratDomainPrimToken :: PackratDomain phi PRPrimTokenIx
PackratDomainEndOfInput :: PackratDomain phi PREndOfInputIx
instance DomainMap (PackratDomain phi) phi PRBaseIx where
supIx = PackratDomainBase
subIx (PackratDomainBase idx) = idx
instance (MemoFam phi) => MemoFam (PackratDomain phi) where
data Memo (PackratDomain phi) v = PRMemo (v PRPrimTokenIx, v PREndOfInputIx, Memo phi (SubVal PRBaseIx v))
toMemo f = PRMemo (f PackratDomainPrimToken, f PackratDomainEndOfInput, toMemo $ \idx -> MkSubVal $ f $ PackratDomainBase idx)
fromMemo (PRMemo (_, _, bm)) (PackratDomainBase idx) = unSubVal $ fromMemo bm idx
fromMemo (PRMemo (v, _, _)) (PackratDomainPrimToken) = v
fromMemo (PRMemo (_, v, _)) (PackratDomainEndOfInput) = v
data PackratValue phi t r ix where
PRPrimTokenValue :: ConcreteToken t -> PackratValue phi t r PRPrimTokenIx
PREndOfInputValue :: PackratValue phi t r PREndOfInputIx
PRBaseValue :: r ix -> PackratValue phi t r (PRBaseIx ix)
unPRPrimTokenValue :: PackratValue phi t r PRPrimTokenIx -> ConcreteToken t
unPRPrimTokenValue (PRPrimTokenValue c) = c
newtype PRResult phi r t ix = PRResult {
unPRResult :: Result phi r t (PackratValue phi t r ix)
}
newtype Derivs phi r t = Derivs {
unDerivs :: forall ix. PackratDomain phi ix -> PRResult phi r t ix
}
buildDerivs :: forall phi r t. (Token t, MemoFam phi) => (forall ix. PackratDomain phi ix -> PRResult phi r t ix) -> Derivs phi r t
buildDerivs f = Derivs memoizedF where
memoizedF :: forall ix. PackratDomain phi ix -> PRResult phi r t ix
memoizedF = memoFamily f
type InternalPRRule phi r t v = Derivs phi r t -> Result phi r t v
type InternalGrammar phi r t = forall ix. phi ix -> InternalPRRule phi r t (r ix)
data PackratRule phitop rtop phi ixT r t v =
PackratRule {
runParse :: InternalGrammar phitop rtop t ->
(forall ix. phi ix -> rtop (ApplyIxMap ixT ix) -> r ix) ->
(forall ix. phi ix -> phitop (ApplyIxMap ixT ix)) ->
InternalPRRule phitop rtop t v
}
type PackratGrammar phitop rtop phi ixT rr r t = forall ix. phi ix -> PackratRule phitop rtop phi ixT rr t (r ix)
instance ProductionRule (PackratRule phitop rtop phi ixT r t) where
a >>> b = PackratRule $ \g rd si d0 ->
case runParse a g rd si d0 of
Parsed f d1 -> case runParse b g rd si d1 of
Parsed x d2 -> Parsed (f x) d2
_ -> NoParse
_ -> NoParse
a ||| b = PackratRule $ \g rd si d ->
case runParse a g rd si d of
Parsed v1 d1 -> Parsed v1 d1
_ -> case runParse b g rd si d of
Parsed v2 d2 -> Parsed v2 d2
_ -> NoParse
die = PackratRule $ \_ _ _ _ -> NoParse
endOfInput = PackratRule $ \_ _ _ d ->
case unPRResult $ unDerivs d PackratDomainEndOfInput of
Parsed _ d' -> Parsed () d'
_ -> NoParse
instance EpsProductionRule (PackratRule phitop rtop phi ixT r t) where
epsilon v = PackratRule $ \_ _ _ -> Parsed v
instance LiftableProductionRule (PackratRule phitop rtop phi ixT r t) where
epsilonL v _ = epsilon v
instance (Token t) => TokenProductionRule (PackratRule phitop rtop phi ixT r t) t where
token c = PackratRule $ \_ _ _ d ->
case unPRResult$ unDerivs d PackratDomainPrimToken of
Parsed v' d' | classify (unPRPrimTokenValue v') == c -> Parsed (unPRPrimTokenValue v') d'
_ -> NoParse
instance RecProductionRule (PackratRule phitop rtop phi ixT r t) phi r where
ref (idx :: phi ix) =
PackratRule $ \grammar rd si d ->
fmap (rd idx) $ grammar (si idx) d
toInternalGrammar :: PackratGrammar phi r phi IxMapId r r t -> InternalGrammar phi r t
toInternalGrammar g idx =
runParse (g idx) (toInternalGrammar g) (\_ -> id) id
parsePackratAll :: forall phi r t. (Token t, MemoFam phi) => InternalGrammar phi r t -> [ConcreteToken t] -> Derivs phi r t
parsePackratAll grammar s =
let
derivs :: forall ix. PackratDomain phi ix -> PRResult phi r t ix
derivs (PackratDomainPrimToken) = case s of
(c:s') -> PRResult $ Parsed (PRPrimTokenValue c) (parsePackratAll grammar s')
_ -> PRResult NoParse
derivs (PackratDomainBase ruleId) = PRResult $ fmap PRBaseValue $ grammar ruleId (buildDerivs derivs)
derivs (PackratDomainEndOfInput) = case s of
[] -> PRResult $ Parsed PREndOfInputValue $ Derivs $ const $ PRResult NoParse
_ -> PRResult NoParse
in buildDerivs derivs
instance SuperProductionRule (PackratRule phitop rtop) where
subref = prSubRef
prSubRef :: forall phitop phi phi' rtop r ixT t ix supIxT . (DomainEmbedding phi phi' supIxT, HFunctor phi (PF phi)) =>
(forall ix'. phi' ix' -> PackratRule phitop rtop phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix')) ->
phi' ix -> phi (supIxT ix) ->
PackratRule phitop rtop phi ixT r t (PF phi r (supIxT ix))
prSubRef subgram idxb idx = PackratRule $ \outgram rd supIxTop ->
let
subrule :: PackratRule phitop rtop phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix)
subrule = subgram idxb
rd' :: forall ix' . phi' ix' -> rtop (ApplyIxMap ixT (supIxT ix')) -> SubVal supIxT r ix'
rd' idx' v = MkSubVal $ rd (supIx idx') v
supIx' :: forall ix' . phi' ix' -> phitop (ApplyIxMap ixT (supIxT ix'))
supIx' idx' = supIxTop (supIx idx' :: phi (supIxT ix'))
oprrule :: InternalPRRule phitop rtop t (PF phi' (SubVal supIxT r) ix)
oprrule = runParse subrule outgram rd' supIx'
nprrule :: InternalPRRule phitop rtop t (PF phi r (supIxT ix))
nprrule = fmap (supPF idxb idx) . oprrule
in nprrule
instance LoopProductionRule (PackratRule phitop rtop phi ixT r t) phi r where
manyRef = manyInf . ref
parsePackrat :: forall phi r ix t. (Token t, MemoFam phi) =>
ProcessingContextFreeGrammar phi t r ->
phi ix -> [ConcreteToken t] -> Result phi r t (r ix)
parsePackrat usergram ruleId s =
let
grammar :: forall ix'. phi ix' -> Derivs phi r t -> Result phi r t (r ix')
grammar = toInternalGrammar usergram
result :: Result phi r t (PackratValue phi t r (PRBaseIx ix))
result = unPRResult $ unDerivs (parsePackratAll grammar s) (PackratDomainBase ruleId)
in case result of
Parsed (PRBaseValue v) d -> Parsed v d
_ -> NoParse