diff --git a/rlp.cabal b/rlp.cabal index dac6a5b..b44fe23 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -71,6 +71,7 @@ library , extra >= 1.7.0 && < 2 , semigroupoids , comonad + , lens hs-source-dirs: src default-language: GHC2021 diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 9c91493..95d01e2 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -54,6 +54,22 @@ data RlpcPs type instance XRec RlpcPs f = Located (f RlpcPs) type instance IdP RlpcPs = PsName +type instance XFunD RlpcPs = () +type instance XDataD RlpcPs = () +type instance XInfixD RlpcPs = () +type instance XTySigD RlpcPs = () +type instance XXDeclD RlpcPs = () + +type instance XLetE RlpcPs = () +type instance XVarE RlpcPs = () +type instance XLamE RlpcPs = () +type instance XCaseE RlpcPs = () +type instance XIfE RlpcPs = () +type instance XAppE RlpcPs = () +type instance XLitE RlpcPs = () +type instance XParE RlpcPs = () +type instance XOAppE RlpcPs = () + type PsName = Text -------------------------------------------------------------------------------- diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index b2eee70..ecfb786 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -16,8 +16,20 @@ module Rlp.Syntax , ConAlt(..) , Binding(..), Binding' - -- * Trees That Grow extensions - , UnXRec(..), MapXRec(..), XRec, IdP + -- * Trees That Grow boilerplate + -- ** Extension points + , IdP, XRec, UnXRec(..), MapXRec(..) + -- *** Decl + , XFunD, XTySigD, XInfixD, XDataD, XXDeclD + -- *** RlpExpr + , XLetE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE + , XParE, XOAppE + -- ** Pattern synonyms + -- *** Decl + , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD + -- *** RlpExpr + , pattern LetE, pattern VarE, pattern LamE, pattern CaseE, pattern IfE + , pattern AppE, pattern LitE, pattern ParE, pattern OAppE ) where ---------------------------------------------------------------------------------- @@ -61,12 +73,39 @@ type RlpType' p = XRec p RlpType deriving instance (PhaseShow p) => Show (RlpType p) -data Decl p = FunD (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) - | TySigD [IdP p] (RlpType' p) - | DataD (IdP p) [IdP p] [ConAlt p] - | InfixD Assoc Int (IdP p) +data Decl p = FunD' (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) + | TySigD' (XTySigD p) [IdP p] (RlpType' p) + | DataD' (XDataD p) (IdP p) [IdP p] [ConAlt p] + | InfixD' (XInfixD p) Assoc Int (IdP p) + | XDeclD' !(XXDeclD p) -deriving instance (Show (IdP p), PhaseShow p) => Show (Decl p) +deriving instance + ( Show (XFunD p), Show (XTySigD p) + , Show (XDataD p), Show (XInfixD p) + , Show (XXDeclD p) + , PhaseShow p + ) + => Show (Decl p) + +type family XFunD p +type family XTySigD p +type family XDataD p +type family XInfixD p +type family XXDeclD p + +pattern FunD :: (XFunD p ~ ()) + => (IdP p) -> [Pat' p] -> (RlpExpr' p) -> (Maybe (Where p)) + -> Decl p +pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> (RlpType' p) -> Decl p +pattern DataD :: (XDataD p ~ ()) => (IdP p) -> [IdP p] -> [ConAlt p] -> Decl p +pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p +pattern XDeclD :: (XXDeclD p ~ ()) => Decl p + +pattern FunD n as e wh = FunD' () n as e wh +pattern TySigD ns t = TySigD' () ns t +pattern DataD n as cs = DataD' () n as cs +pattern InfixD a p n = InfixD' () a p n +pattern XDeclD = XDeclD' () type Decl' p = XRec p Decl @@ -79,17 +118,57 @@ data ConAlt p = ConAlt (IdP p) [RlpType' p] deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p) -data RlpExpr p = LetE [Binding' p] (RlpExpr' p) - | VarE (IdP p) - | LamE [Pat p] (RlpExpr' p) - | CaseE (RlpExpr' p) [(Alt p, Where p)] - | IfE (RlpExpr' p) (RlpExpr' p) (RlpExpr' p) - | AppE (RlpExpr' p) (RlpExpr' p) - | LitE (Lit p) - | ParE (RlpExpr' p) - | OAppE (IdP p) (RlpExpr' p) (RlpExpr' p) +data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p) + | VarE' (XVarE p) (IdP p) + | LamE' (XLamE p) [Pat p] (RlpExpr' p) + | CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)] + | IfE' (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p) + | AppE' (XAppE p) (RlpExpr' p) (RlpExpr' p) + | LitE' (XLitE p) (Lit p) + | ParE' (XParE p) (RlpExpr' p) + | OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p) + | XRlpExprE' (XXRlpExprE p) -deriving instance (PhaseShow p) => Show (RlpExpr p) +type family XLetE p +type family XVarE p +type family XLamE p +type family XCaseE p +type family XIfE p +type family XAppE p +type family XLitE p +type family XParE p +type family XOAppE p +type family XXRlpExprE p + +pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p +pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p +pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p +pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p +pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p +pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p +pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p +pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p + +pattern LetE bs e = LetE' () bs e +pattern VarE n = VarE' () n +pattern LamE as e = LamE' () as e +pattern CaseE e as = CaseE' () e as +pattern IfE c a b = IfE' () c a b +pattern AppE f x = AppE' () f x +pattern LitE l = LitE' () l +pattern ParE e = ParE' () e +pattern OAppE n a b = OAppE' () n a b +pattern XRlpExprE = XRlpExprE' () + +deriving instance + ( Show (XLetE p), Show (XVarE p), Show (XLamE p) + , Show (XCaseE p), Show (XIfE p), Show (XAppE p) + , Show (XLitE p), Show (XParE p), Show (XOAppE p) + , Show (XXRlpExprE p) + , PhaseShow p + ) => Show (RlpExpr p) type RlpExpr' p = XRec p RlpExpr