module Text.GrammarCombinators.Utils.LiftGrammar (
liftGrammar,
unfoldAndLiftGrammar
) where
import Text.GrammarCombinators.Base
import Language.Haskell.TH.Syntax
import Control.Monad
data LiftedRule (phi :: * -> *) (r :: * -> *) t v =
MkLR { liftRule :: Q Exp -> Q Exp -> Q Exp -> Q Exp }
instance ProductionRule (LiftedRule phi r t) where
endOfInput = MkLR $ \_ _ _ -> [| endOfInput |]
a >>> b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) >>> $(liftRule b r mr m1r) |]
a ||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) ||| $(liftRule b r mr m1r) |]
die = MkLR $ \_ _ _ -> [| die |]
instance BiasedProductionRule (LiftedRule phi r t) where
a >||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) >||| $(liftRule b r mr m1r) |]
a <||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) <||| $(liftRule b r mr m1r) |]
instance PenaltyProductionRule (LiftedRule phi r t) where
penalty p br = MkLR $ \r mr m1r -> [| penalty p $(liftRule br r mr m1r) |]
instance LiftableProductionRule (LiftedRule phi r t) where
epsilonL _ q = MkLR $ \_ _ _ -> [|epsilon $(q)|]
instance (Token t) => TokenProductionRule (LiftedRule phi r t) t where
token tt = MkLR $ \_ _ _ -> [| token $(lift tt) |]
anyToken = MkLR $ \_ _ _ -> [| anyToken |]
instance (LiftFam phi) =>
RecProductionRule (LiftedRule phi r t) phi r where
ref idx = MkLR $ \r _ _ -> [| $(r) $(return $ liftIdxE idx) |]
instance (LiftFam phi) =>
LoopProductionRule (LiftedRule phi r t) phi r where
manyRef idx = MkLR $ \_ mr _ -> [| $(mr) $(return $ liftIdxE idx) |]
many1Ref idx = MkLR $ \_ _ m1r -> [| $(m1r) $(return $ liftIdxE idx) |]
liftGrammar' :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
Q Exp -> Q Exp -> Q Exp ->
Q Dec
liftGrammar' gram name refQ manyRefQ many1RefQ =
let
clause :: phi ix -> Q Clause
clause idx = do lr <- liftRule (gram idx) refQ manyRefQ many1RefQ
return $ Clause [liftIdxP idx] (NormalB lr) []
addClause idx b = do c <- clause idx
cs <- b
return (c:cs)
clauses = foldFam addClause (return [])
in liftM (FunD name) clauses
liftGrammar :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
Q Type ->
Q [Dec]
liftGrammar gram name grammarType =
let sig = do t <- grammarType
return $ SigD name t
fundef = liftGrammar' gram name [|ref|] [|manyRef|] [|many1Ref|]
in do s <- sig
f <- fundef
return [s,f]
unfoldAndLiftGrammar :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
Q Type ->
Q [Dec]
unfoldAndLiftGrammar gram name gramType =
let refQ = return $ VarE name
manyRefQ = return $ AppE (AppE (VarE '(.)) (VarE 'manyInf)) $ VarE name
many1RefQ = return $ AppE (AppE (VarE '(.)) (VarE 'many1Inf)) $ (VarE name)
sig = do t <- gramType
return $ SigD name t
fundef = liftGrammar' gram name refQ manyRefQ many1RefQ
in do s <- sig
d <- fundef
return [s,d]