AspectAG 0.6.0.0 → 0.7.0.0
raw patch · 5 files changed
+448/−163 lines, 5 filesdep +ghc-primdep +loch-thdep −taggeddep ~basedep ~containersdep ~poly-rec
Dependencies added: ghc-prim, loch-th
Dependencies removed: tagged
Dependency ranges changed: base, containers, poly-rec, requirements
Files
- AspectAG.cabal +9/−7
- src/Language/Grammars/AspectAG.hs +347/−125
- src/Language/Grammars/AspectAG/RecordInstances.hs +26/−20
- src/Language/Grammars/AspectAG/TH.hs +13/−11
- src/Language/Grammars/AspectAG/THGen.hs +53/−0
AspectAG.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.6.0.0+version: 0.7.0.0 -- A short (one-line) description of the package. synopsis: Strongly typed Attribute Grammars implemented using type-level programming.@@ -36,7 +36,7 @@ -- patches. maintainer: jpgarcia@fing.edu.uy -category: Language+category: Language, Aspect Oriented Programming, build-type: Simple @@ -59,6 +59,7 @@ -- Modules exported by the library. exposed-modules: Language.Grammars.AspectAG, Language.Grammars.AspectAG.TH,+ Language.Grammars.AspectAG.THGen, Language.Grammars.AspectAG.HList, Language.Grammars.AspectAG.RecordInstances @@ -87,13 +88,14 @@ InstanceSigs -- Other library packages from which modules are imported.- build-depends: base >=4.11 && <4.15,- tagged >=0.8,- containers >= 0.5,- template-haskell >= 2.13,+ build-depends: base >=4.11 && <1.18,+ containers,+ ghc-prim, mtl >= 2.0,+ poly-rec >=0.6 && <0.7, requirements >=0.6 && <0.7,- poly-rec >=0.6 && <0.7+ template-haskell >= 2.13,+ loch-th -- Directories containing source files.
src/Language/Grammars/AspectAG.hs view
@@ -1,3 +1,4 @@+ {-| Module : Language.Grammars.AspectAG Description : Main module, First-class attribute grammars@@ -30,26 +31,31 @@ {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE DatatypeContexts #-} module Language.Grammars.AspectAG ( -- * Rules Rule, CRule(..),+ Fam,+ chi, par, -- ** Defining Rules- syndef, syndefM, syn,+ syndef, syndefM, syn, -- syndefC, - synmod, synmodM,-+ synmod, synmodM, -- synP, - inh, inhdef, inhdefM,+ inh,+ inhdef, inhdefM, inhmod, inhmodM, emptyRule, emptyRuleAtPrd,- ext,+ emptyRuleInst,+ ext, (.+.), extP, -- * Aspects -- ** Building Aspects.@@ -61,7 +67,7 @@ (.+:),(◃), (.:+.),(▹), (.:+:),(⋈),- + (.#..), CAspect(..), Label(Label), Prod(..), T(..), NT(..), Child(..), Att(..),@@ -71,14 +77,20 @@ at, lhs, sem_Lit, knitAspect,+ knit, traceAspect, traceRule, copyAtChi,- use,+ -- use, emptyAspectC, emptyAspectForProds, module Data.GenRec,- module Language.Grammars.AspectAG.HList+ module Language.Grammars.AspectAG.HList,+ Terminal,+ NonTerminal,++ (+++),+ empties ) where @@ -86,6 +98,7 @@ import Language.Grammars.AspectAG.HList import Language.Grammars.AspectAG.RecordInstances + import Data.Type.Require hiding (emptyCtx) import Data.GenRec@@ -98,7 +111,16 @@ import Data.Maybe import Data.Type.Equality import Control.Monad.Reader+import Data.Functor.Identity+import GHC.Types +import Debug.Trace.LocationTH++infixr 3 &&+type family (a :: Bool) && (b :: Bool) where+ True && True = True+ _ && _ = False+ class SemLit a where sem_Lit :: a -> Attribution ('[] :: [(Att,Type)]) -> Attribution '[ '( 'Att "term" a , a)]@@ -151,6 +173,12 @@ emptyRule = CRule $ \Proxy -> \fam inp -> inp +emptyRuleInst :: KList sc -> CRule ctx prd sc ip ic sp ic sp+emptyRuleInst _ =+ CRule $ \Proxy -> \fam ->+ case fam of+ Fam _ _ -> \fam -> fam+ emptyRuleAtPrd :: Label prd -> CRule ctx prd sc ip ic' sp' ic' sp' emptyRuleAtPrd Label = emptyRule @@ -182,10 +210,12 @@ -- | |traceAspect| adds context to an aspect. traceAspect (_ :: Proxy (e::ErrorMessage))- = mapCAspect $ \(_ :: Proxy ctx) -> Proxy @ ((Text "aspect ":<>: e) : ctx)+ = mapCAspect $ \(_ :: Proxy ctx) ->+ Proxy @ ((Text "- traceAspect: " :<>: e) : ctx) traceRule (_ :: Proxy (e::ErrorMessage))- = mapCRule $ \(_ :: Proxy ctx) -> Proxy @ ((Text "rule ":<>: e) : ctx)+ = mapCRule $ \(_ :: Proxy ctx) ->+ Proxy @ (Text "- traceRule: " :<>: e : ctx) mapCRule :: (Proxy ctx -> Proxy ctx')@@ -265,17 +295,24 @@ (⋈) = comAspect infixr 4 ⋈ -ext' :: CRule ctx prd sc ip ic sp ic' sp'- -> CRule ctx prd sc ip a b ic sp+ext' :: RequireEq prd prd' (Text "ext":ctx) =>+ CRule ctx prd sc ip ic sp ic' sp'+ -> CRule ctx prd' sc ip a b ic sp -> CRule ctx prd sc ip a b ic' sp' (CRule f) `ext'` (CRule g) = CRule $ \ctx input -> f ctx input . g ctx input +type PCRule p ctx prd sc ip ic sp ic' sp'+ = Reader p (CRule ctx prd sc ip ic sp ic' sp') +-- | extension of polymorphic rules+extP l r = \(p ::Proxy p) -> l p `ext` r p++ -- | Given two rules for a given (the same) production, it combines -- them. Note that the production equality is visible in the context, -- not sintactically. This is a use of the 'Require' pattern.-ext :: RequireEq prd prd' (Text "ext":ctx) +ext :: RequireEq prd prd' (Text "ext":ctx) => CRule ctx prd sc ip ic sp ic' sp' -> CRule ctx prd' sc ip a b ic sp -> CRule ctx prd sc ip a b ic' sp'@@ -288,6 +325,7 @@ infixr 6 .+. (.+.) = ext + -- | combine a rule with an aspect (wrapper) data OpComRA (ctx :: [ErrorMessage]) (prd :: Prod)@@ -351,10 +389,6 @@ instance ( Require (OpComRA ctx prd rule asp) ctx- -- , ReqR (OpComRA ctx prd rule asp) ~ Rec- -- PrdReco- -- (UnWrap- -- (ReqR (OpComRA ctx prd (CRule ctx prd sc ip ic sp ic' sp') asp))) , ReqR (OpComRA ctx prd rule asp) ~ Aspect a0 ) =>@@ -373,7 +407,47 @@ +-- | extract Rule from Aspect+-- data OpGetRule (prd :: Prod)+-- (a :: [(Prod, Type)]) where+-- OpGetRule :: Label prd -> CAspect ctx a -> OpGetRule prd a +-- instance+-- (Require (OpLookup AttReco prd a) ctx,+-- ReqR (OpLookup PrdReco prd a) ~ Rule prd sc ip ic sp ic' sp'+-- )+-- =>+-- Require (OpGetRule prd a) ctx where+-- type ReqR (OpGetRule prd a) = ReqR (OpLookup @Prod @Type AttReco prd a)+-- req ctx (OpGetRule prd (CAspect ca)) =+-- let rule = req ctx (OpLookup prd (ca Proxy))+-- in CRule $ \ctx -> rule++data OpGetRA (ctx :: [ErrorMessage])+ (prd :: Prod)+ (a :: [(Prod, Type)]) where+ OpGetRA :: Label prd -> Aspect a -> OpGetRA ctx prd a++instance+ (Require (OpLookup PrdReco prd a) ctx)+ =>+ Require (OpGetRA ctx prd a) ctx where+ type ReqR (OpGetRA ctx prd a) = ReqR (OpLookup PrdReco prd a)+ req ctx (OpGetRA prd a) = req ctx (OpLookup prd a)+-- todo: do not return units when not found+++-- (.#..)+-- :: (Require (OpLookup PrdReco prd r) (('ShowType r : ctx0)),+-- ReqR (OpLookup PrdReco prd r) ~ CRule ctx prd sc ip ic sp ic' sp') =>+-- CAspect ctx r -> Label prd -> CRule ctx prd sc ip ic sp ic' sp'+ca .#.. prd+ = (mkAspect ca Proxy) # prd+++++-- | add rule to an aspect data OpComAsp (al :: [(Prod, Type)]) (ar :: [(Prod, Type)]) where OpComAsp :: Aspect al -> Aspect ar -> OpComAsp al ar@@ -409,18 +483,42 @@ type family SP (rule :: Type) where SP (Rule prd sc ip ic sp ic' sp') = sp SP (CRule ctx prd sc ip ic sp ic' sp') = sp-+ -type family Syndef t t' ctx ctx' att sp sp' prd :: Constraint where- Syndef t t' ctx ctx' att sp sp' prd =- ( RequireEq t t' ctx'- , RequireR (OpExtend AttReco ('Att att t) t sp) ctx (Attribution sp')- , ctx'- ~ ((Text "syndef("- :<>: ShowTE ('Att att t) :<>: Text ", "- :<>: ShowTE prd :<>: Text ")") ': ctx)+type family Syndef t t' ctx att sp sp' prd prd' :: Constraint where+ Syndef t t' ctx att sp sp' prd prd' =+ ( RequireEqWithMsg t t' AttTypeMatch ctx--+ , RequireEqWithMsg prd prd' PrdTypeMatch ctx+ , RequireR (OpExtend AttReco ('Att att t) t' sp) ctx (Attribution sp') ) +data AttTypeMatch (a::k)(b::k) -- where+ -- AttTypeMatch :: a -> b -> AttTypeMatch a b+type instance Eval (AttTypeMatch t1 t2) =+ ( ShowTE t1 :<>: Text " /= " :<>: ShowTE t2 :$$:+ Text "type mismatch in attribute definition" :$$:+ Text "attribute type does not match with \+ \the computation that defines it")++data PrdTypeMatch (a :: k)(b :: k)+type instance Eval (PrdTypeMatch t1 t2) =+ ( ShowTE t1 :<>: Text " /= " :<>: ShowTE t2 :$$:+ Text "mismatch in production type. \+ \Perhaps you are trying to get data from a \+ \children of a wrong production?")++data ChiPrdMatch (a :: Prod)(b :: Prod)+type instance Eval (ChiPrdMatch ('Prd att nt) ('Prd att' nt')) =+ ( ShowTE ('Prd att nt) :<>: Text " /= " :<>: ShowTE ('Prd att' nt') :$$:+ Text "production and child mismatch in inherited attribute definition")+++data GetAttTypeMatch (a::k)(b::k) where+ GetAttTypeMatch :: a -> b -> GetAttTypeMatch a b+type instance Eval (GetAttTypeMatch t1 t2) =+ ( ShowTE t1 :<>: Text " /= " :<>: ShowTE t2 :$$:+ Text "ill typed attribute computation")+ -- | The function 'syndef' adds the definition of a synthesized -- attribute. It takes an attribute label 'att' representing the -- name of the new attribute; a production label 'prd' representing@@ -428,15 +526,47 @@ -- assigned to this attribute, given a context and an input -- family. It updates the output constructed thus far. syndef- :: Syndef t t' ctx ctx' att sp sp' prd- => forall sc ip ic . Label ('Att att t)+ :: Syndef t t' ctx att sp sp' prd prd' + => forall sc ip ic .+ Label ('Att att t) -> Label prd- -> (Proxy ctx' -> Fam prd sc ip -> t')+ -> (Proxy ctx -> Fam prd' sc ip -> t') -> CRule ctx prd sc ip ic sp ic sp' syndef att prd f = CRule $ \ctx inp (Fam ic sp) -> Fam ic $ req ctx (OpExtend att (f Proxy inp) sp) ++data SyndefT t t' (ctx :: [ErrorMessage])+ (att :: Symbol)+ (sp :: [(Att, Type)])+ (sp' :: [(Att, Type)]) prd prd'++class Syndef' a+instance+ ( RequireEqWithMsg t t' AttTypeMatch ctx--+ , RequireEqWithMsg prd prd' PrdTypeMatch ctx+ , RequireR (OpExtend AttReco ('Att att t) t' sp) ctx (Attribution sp')+ )+ => Syndef' (SyndefT t t' ctx att sp sp' prd prd' )++data Dummy+instance Syndef' Dummy++-- syndef'+-- :: Syndef' (SyndefT t t' ctx att sp sp' prd prd') +-- => forall sc ip ic .+-- Label ('Att att t)+-- -> Label prd+-- -> (Proxy ctx -> Fam prd' sc ip -> t')+-- -> CRule ctx prd' sc ip ic sp ic sp'+-- syndef' att prd f+-- = CRule $ \ctx inp (Fam ic sp)+-- -> Fam ic $ req ctx (OpExtend att (f Proxy inp) sp)++++ -- | As 'syndef', the function 'syndefM' adds the definition of a -- synthesized attribute. It takes an attribute label 'att' -- representing the name of the new attribute; a production label@@ -454,22 +584,61 @@ -- foo = syndefM att_size p_cons $ do sizeatchi <- at ch_tail att_size -- return (sizeatchi + 1) -- @-syndefM- :: Syndef t t' ctx ctx' att sp sp' prd- => Label ('Att att t)- -> Label prd- -> Reader (Proxy ctx', Fam prd sc ip) t'- -> CRule ctx prd sc ip ic sp ic sp'-syndefM att prd = syndef att prd . def --- | This is simply an alias for 'syndefM'-syn = syndefM+data SyndefMsg+data InhdefMsg +type family MkMsg msgtype att t prd nt where+ MkMsg SyndefMsg att t prd nt =+ Text "- syndef: definition of attribute "+ :<>: ShowTE ('Att att t) :$$: Text " in production "+ :<>: ShowTE ('Prd prd nt)+ MkMsg InhdefMsg att t prd nt =+ Text "- inhdef: definition of attribute "+ :<>: ShowTE ('Att att t) :$$: Text " in production "+ :<>: ShowTE ('Prd prd nt) +mkSyndefMsg :: Label ('Att att t) -> Label ('Prd prd nt)+ -> Proxy (MkMsg SyndefMsg att t prd nt)+mkSyndefMsg Label Label = Proxy++mkMsg :: Proxy msg -> Label ('Att att t) -> Label ('Prd prd nt)+ -> Proxy (MkMsg msg att t prd nt)+mkMsg Proxy Label Label = Proxy+++-- | This is simply an alias for 'syndef'+syn+ :: Syndef t t' (MkMsg SyndefMsg att t prd nt ': ctx) att sp sp' prd prd'+ => Label ('Att att t)+ -> Label ('Prd prd nt)+ -> Reader (Proxy (MkMsg SyndefMsg att t prd nt ': ctx),+ Fam ('Prd prd' nt) sc ip) t'+ -> CRule ctx ('Prd prd nt) sc ip ic sp ic sp'+syn att prd f+ = mapCRule (mkSyndefMsg att prd `consErr`) $ (syndef att prd . def) f++syndefM+ :: Syndef t t' (MkMsg SyndefMsg att t prd nt ': ctx) att sp sp' prd prd'+ => Label ('Att att t)+ -> Label ('Prd prd nt)+ -> Reader (Proxy (MkMsg SyndefMsg att t prd nt ': ctx),+ Fam ('Prd prd' nt) sc ip) t'+ -> CRule ctx ('Prd prd nt) sc ip ic sp ic sp'+syndefM att prd f+ = mapCRule (mkMsg (Proxy @SyndefMsg) att prd `consErr`)+ $ (syndef att prd . def) f++-- |synthesized poly rule+--synP (att :: forall v. Label ('Att k v)) prd rul+-- = \(p :: Proxy p) -> syndefM (att @ p) prd rul+ -- | This is simply an alias for 'inhdefM'-inh = inhdefM+--inh = inhdefM +--inhP (att :: forall v. Label ('Att k v)) prd chi rul+-- = \(p :: Proxy p) -> inhdefM (att @ p) prd chi rul synmod :: RequireR (OpUpdate AttReco ('Att att t) t r) ctx (Attribution sp')@@ -499,58 +668,63 @@ synmodM att prd = synmod att prd . def -type family Inhdef t t' ctx ctx' att r v2 prd nt chi ntch ic ic' n where- Inhdef t t' ctx ctx' att r v2 prd nt chi ntch ic ic' n =- ( RequireEq t t' ctx'- , RequireR (OpExtend AttReco ('Att att t) t r) ctx (Attribution v2)- , RequireR (OpUpdate (ChiReco ('Prd prd nt))- ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx- (ChAttsRec ('Prd prd nt) ic')- , RequireR (OpLookup (ChiReco ('Prd prd nt))- ('Chi chi ('Prd prd nt) ntch) ic) ctx- (Attribution r)- , RequireEq ntch ('Left n) ctx'- , ctx' ~ ((Text "inhdef("- :<>: ShowTE ('Att att t) :<>: Text ", "- :<>: ShowTE ('Prd prd nt) :<>: Text ", "- :<>: ShowTE ('Chi chi ('Prd prd nt) ntch) :<>: Text ")")- ': ctx)+type family Inhdef t t' ctx att r v2 prd prd' nt nt' chi ntch ic ic' n+ where+ Inhdef t t' ctx att r v2 prd prd' nt nt' chi ntch ic ic' n+ = ( RequireEqWithMsg t t' AttTypeMatch ctx+ , RequireEqWithMsg ('Prd prd nt) ('Prd prd' nt') ChiPrdMatch ctx+ --, RequireEq nt nt' ctx+ , RequireR (OpExtend AttReco ('Att att t) t' r) ctx (Attribution v2)+ , RequireR (OpUpdate (ChiReco ('Prd prd nt))+ ('Chi chi ('Prd prd' nt') ntch) v2 ic) ctx+ (ChAttsRec ('Prd prd' nt') ic')+ , RequireR (OpLookup (ChiReco ('Prd prd nt))+ ('Chi chi ('Prd prd' nt') ntch) ic) ctx (Attribution r)+ --, ntch ~ ('Left n) )- inhdef- :: Inhdef t t' ctx ctx' att r v2 prd nt chi ntch ic ic' n- =>- Label ('Att att t)- -> Label ('Prd prd nt)- -> Label ('Chi chi ('Prd prd nt) ntch)- -> (Proxy ctx' -> Fam ('Prd prd nt) sc ip -> t')- -> forall sp . CRule ctx ('Prd prd nt) sc ip ic sp ic' sp-inhdef att prd chi f- = CRule $ \ctx inp (Fam ic sp)- -> let ic' = req ctx (OpUpdate chi catts' ic)- catts = req ctx (OpLookup chi ic)- catts'= req ctx (OpExtend att (f Proxy inp) catts)- in Fam ic' sp+ :: Inhdef t t' ctx att r v2 prd prd' nt nt' chi ntch ic ic' n+ => Label ('Att att t)+ -> Label ('Prd prd nt)+ -> Label ('Chi chi ('Prd prd' nt') ntch)+ -> (Proxy ctx -> Fam ('Prd prd nt) sc ip -> t')+ -> forall sp . CRule ctx ('Prd prd nt) sc ip ic sp ic' sp +inhdef att prd chi f =+ CRule $ \ctx inp (Fam ic sp) ->+ let ic' = req ctx (OpUpdate chi catts' ic)+ catts = req ctx (OpLookup chi ic)+ catts' = req ctx (OpExtend att (f Proxy inp) catts)+ in Fam ic' sp inhdefM- :: Inhdef t t' ctx ctx' att r v2 prd nt chi ntch ic ic' n- =>- Label ('Att att t)+ :: Inhdef t t' (MkMsg InhdefMsg att t prd nt ': ctx)+ att r v2 prd prd' nt nt' chi ntch ic ic' n+ => Label ('Att att t) -> Label ('Prd prd nt)- -> Label ('Chi chi ('Prd prd nt) ntch)- -> Reader (Proxy ctx', Fam ('Prd prd nt) sc ip) t'+ -> Label ('Chi chi ('Prd prd' nt') ntch)+ -> Reader (Proxy (MkMsg InhdefMsg att t prd nt ': ctx), Fam ('Prd prd nt) sc ip) t' -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp-inhdefM att prd chi = inhdef att prd chi . def-+inhdefM att prd chi f = mapCRule (mkMsg (Proxy @InhdefMsg) att prd `consErr`)+ $ (inhdef att prd chi . def) f +inh+ :: Inhdef t t' (MkMsg InhdefMsg att t prd nt ': ctx)+ att r v2 prd prd' nt nt' chi ntch ic ic' n+ => Label ('Att att t)+ -> Label ('Prd prd nt)+ -> Label ('Chi chi ('Prd prd' nt') ntch)+ -> Reader (Proxy (MkMsg InhdefMsg att t prd nt ': ctx), Fam ('Prd prd nt) sc ip) t'+ -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp+inh att prd chi f = mapCRule (mkMsg (Proxy @InhdefMsg) att prd `consErr`)+ $ (inhdef att prd chi . def) f inhmod :: ( RequireEq t t' ctx'- , RequireR (OpUpdate AttReco ('Att att t) t r) ctx+ , RequireR (OpUpdate AttReco ('Att att t) t' r) ctx (Attribution v2) , RequireR (OpUpdate (ChiReco ('Prd prd nt)) ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx@@ -558,7 +732,7 @@ , RequireR (OpLookup (ChiReco ('Prd prd nt)) ('Chi chi ('Prd prd nt) ntch) ic) ctx (Attribution r)- , RequireEq ntch ('Left n) ctx'+ , ntch ~ ('Left n) , ctx' ~ ((Text "inhmod(" :<>: ShowTE ('Att att t) :<>: Text ", " :<>: ShowTE ('Prd prd nt) :<>: Text ", "@@ -580,7 +754,7 @@ inhmodM :: ( RequireEq t t' ctx'- , RequireR (OpUpdate AttReco ('Att att t) t r) ctx+ , RequireR (OpUpdate AttReco ('Att att t) t' r) ctx (Attribution v2) , RequireR (OpUpdate (ChiReco ('Prd prd nt)) ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx@@ -588,7 +762,7 @@ , RequireR (OpLookup (ChiReco ('Prd prd nt)) ('Chi chi ('Prd prd nt) ntch) ic) ctx (Attribution r)- , RequireEq ntch ('Left n) ctx'+ , ntch ~ ('Left n) , ctx' ~ ((Text "inhmod(" :<>: ShowTE ('Att att t) :<>: Text ", " :<>: ShowTE ('Prd prd nt) :<>: Text ", "@@ -606,22 +780,26 @@ lhs :: Label Lhs lhs = Label -class At pos att m where+class Monad m => At pos att m where type ResAt pos att m at :: Label pos -> Label att -> m (ResAt pos att m) -instance ( RequireR (OpLookup (ChiReco prd) ('Chi ch prd nt) chi) ctx+instance ( RequireR (OpLookup (ChiReco prd') ('Chi ch prd nt) chi) ctx (Attribution r) , RequireR (OpLookup AttReco ('Att att t) r) ctx t'- , RequireEq prd prd' ctx- , RequireEq t t' ctx- , RequireEq ('Chi ch prd nt) ('Chi ch prd ('Left ('NT n))) ctx+ , RequireEqWithMsg prd prd' PrdTypeMatch ctx+ , RequireEqWithMsg t t' GetAttTypeMatch ctx+ , ReqR (OpLookup @Att @Type AttReco ('Att att t')+ (UnWrap @Att @Type (Rec AttReco r)))+ ~ t' + , r ~ UnWrap (Attribution r) ) => At ('Chi ch prd nt) ('Att att t) (Reader (Proxy ctx, Fam prd' chi par)) where type ResAt ('Chi ch prd nt) ('Att att t) (Reader (Proxy ctx, Fam prd' chi par))- = t + = ReqR (OpLookup AttReco ('Att att t)+ (UnWrap @Att @Type (ReqR (OpLookup (ChiReco prd) ('Chi ch prd nt) chi)))) at ch att = liftM (\(ctx, Fam chi _) -> let atts = req ctx (OpLookup ch chi) in req ctx (OpLookup att atts))@@ -630,35 +808,59 @@ instance- ( RequireR (OpLookup AttReco ('Att att t) par) ctx t'- , RequireEq t t' ctx- )- => At Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par)) where- type ResAt Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par))- = t- at lhs att- = liftM (\(ctx, Fam _ par) -> req ctx (OpLookup att par)) ask+ ( RequireR (OpLookup @Att @Type AttReco ('Att att t) par) ctx t+ , RequireEqWithMsg t t' AttTypeMatch ctx+ )+ =>+ At Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par)) where+ type ResAt Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par))+ = ReqR (OpLookup @Att @Type AttReco ('Att att t) (UnWrap @Att @Type (Rec AttReco par)))+ at lhs att+ = liftM (\(ctx, Fam _ par) -> req ctx (OpLookup att par)) ask -def :: Reader (Proxy ctx, Fam prd chi par) a- -> (Proxy ctx -> (Fam prd chi par) -> a) def = curry . runReader ter :: ( RequireR (OpLookup (ChiReco prd) pos chi) ctx (Attribution r)- , RequireR (OpLookup AttReco ('Att "term" t) r) ctx t'- , RequireEq prd prd' ctx- , RequireEq t t' ctx- , RequireEq pos ('Chi ch prd (Right ('T t))) ctx- , m ~ Reader (Proxy ctx, Fam prd' chi par) )- => Label pos -> m (ResAt pos ('Att "term" t) m) - -- ter (ch :: Label ('Chi ch prd (Right ('T a)))) = at ch (lit @ a)-ter (ch :: Label ('Chi ch prd (Right ('T t))))- = liftM (\(ctx, Fam chi _) -> let atts = req ctx (OpLookup ch chi)- in req ctx (OpLookup (lit @ t) atts))+ , RequireR (OpLookup AttReco ('Att "term" t) r) ctx t+ , RequireEqWithMsg prd prd' PrdTypeMatch ctx+ , ReqR (OpLookup AttReco ('Att "term" t) (UnWrap @Att @Type (Attribution r)))+ ~ t+ , RequireEq pos ('Chi ch prd rtt) ctx+ , RequireEq rtt (Right ('T t)) ctx)+ => Label pos -> Reader (Proxy ctx, Fam prd' chi par) t+ter (ch :: Label ('Chi ch prd rtt))+ = liftM (\(ctx, Fam chi _) ->+ let atts = req ctx (OpLookup ch chi)+ in req ctx (OpLookup (lit @(FromT (FromRight rtt))) atts)) ask +type family FromRight (t :: Either a b) :: b where+ FromRight (Right t) = t +type family FromT (t :: T) :: b where+ FromT ('T t) = t ++-- ter :: ( RequireR (OpLookup (ChiReco prd) pos chi) ctx+-- (Attribution r)+-- , RequireR (OpLookup AttReco ('Att "term" t) r) ctx t+-- , RequireEqWithMsg prd prd' PrdTypeMatch ctx+-- , ReqR (OpLookup AttReco ('Att "term" t) (UnWrap @Att @Type (Attribution r)))+-- ~ t+-- , RequireEq pos ('Chi ch prd (Right ('T t))) ctx+-- , m ~ Reader (Proxy ctx, Fam prd' chi par) )+-- => Label pos -> m t -- (ResAt pos ('Att "term" t) m) +-- ter (ch :: Label ('Chi ch prd (Right ('T t))))+-- = liftM (\(ctx, Fam chi _) -> let atts = req ctx (OpLookup ch chi)+-- in req ctx (OpLookup (lit @ t) atts))+-- ask+++type instance (UnWrap (Attribution r)) = r+type instance (UnWrap @Att @Type (Rec c r)) = r++ class Kn (fcr :: [(Child, Type)]) (prd :: Prod) where type ICh fcr :: [(Child, [(Att, Type)])] type SCh fcr :: [(Child, [(Att, Type)])]@@ -669,11 +871,9 @@ type SCh '[] = '[] kn _ _ = emptyCh -instance ( lch ~ 'Chi l prd nt- , Kn fc prd- -- , LabelSet ('(lch, sch) : SCh fc)- -- , LabelSet ('(lch, ich) : ICh fc)- ) =>+instance+ Kn fc prd+ => Kn ( '(lch , Attribution ich -> Attribution sch) ': fc) prd where type ICh ( '(lch , Attribution ich -> Attribution sch) ': fc) = '(lch , ich) ': ICh fc@@ -715,7 +915,7 @@ instance ( Empties fcr prd- , chi ~ 'Chi ch prd nt+ -- , chi ~ 'Chi ch prd nt ) => Empties ( '(chi, Attribution e -> Attribution a) ': fcr) prd where@@ -739,7 +939,7 @@ knitAspect (prd :: Label prd) asp fc ip = let ctx = Proxy @ '[]- ctx' = Proxy @ '[Text "knit" :<>: ShowTE prd]+ ctx' = Proxy @ '[Text ("knit:" `AppendSymbol` FromEM (ShowTE prd))] in knit ctx (req ctx' (OpLookup prd ((mkAspect asp) ctx))) fc ip -- | use@@ -800,17 +1000,17 @@ -- 'prd', by applying an operator to the values of 'att' in each non -- terminal in the list 'nts'. -use- :: UseC att prd nts t' sp sc sp' ctx- => Label ('Att att t')- -> Label prd- -> KList nts- -> (t' -> t' -> t')- -> t'- -> forall ip ic' . CRule ctx prd sc ip ic' sp ic' sp'-use att prd nts op unit- = syndef att prd- $ \_ fam -> maybe unit id (usechi att prd nts op $ chi fam)+-- use+-- :: UseC att prd nts t' sp sc sp' ctx+-- => Label ('Att att t')+-- -> Label prd+-- -> KList nts+-- -> (t' -> t' -> t')+-- -> t'+-- -> forall ip ic' . CRule ctx prd sc ip ic' sp ic' sp'+-- use att prd nts op unit+-- = syndef att prd+-- $ \_ fam -> maybe unit id (usechi att prd nts op $ chi fam) type UseC att prd nts t' sp sc sp' ctx =@@ -866,8 +1066,12 @@ -- | a rule to copy one attribute `att` from the parent to the children `chi` copyAtChi att chi- = inh att (prdFromChi chi) chi (at lhs att)+ = inhdef att (prdFromChi chi) chi (at lhs att) +--copyAtChiP (att :: forall t. Label ('Att "" t)) chi+-- = \(p :: Proxy val) -> inhP (att @val) (prdFromChi chi) chi (at lhs att)++ -- | to copy at many children class CopyAtChiList (att :: Att) (chi :: [Child])@@ -899,3 +1103,21 @@ -- (p :: Proxy ( '(sc, ip, ic, sp, ic', sp') ': polys)) -- = copyAtChi att chi -- .+: copyAtChiList @('Att att t) @chs att chs (Proxy @polys)+++++-- * Productions+--data Symbol = N String | Te Name+type family Terminal s :: Either NT T where+ Terminal s = 'Right ('T s)++type family NonTerminal s where+ NonTerminal s = 'Left s+++(+++) :: Proxy e1 -> Proxy e2 -> Proxy (e1 :$$: e2)+Proxy +++ Proxy = Proxy++consErr :: Proxy e -> Proxy es -> Proxy (e : es)+consErr Proxy Proxy = Proxy
src/Language/Grammars/AspectAG/RecordInstances.hs view
@@ -41,29 +41,37 @@ prdFromChi _ = Label -type instance Cmp ('Att a _) ('Att b _) =- CmpSymbol a b+instance OrdType Att where+ type Cmp ('Att a _) ('Att b _)+ = CmpSymbol a b -type instance Cmp ('Prd a _) ('Prd b _) =- CmpSymbol a b+instance OrdType Prod where + type Cmp ('Prd a _) ('Prd b _)+ = CmpSymbol a b -type instance Cmp ('Chi a _ _) ('Chi b _ _) =- CmpSymbol a b+instance OrdType Child where+ type Cmp ('Chi a _ _) ('Chi b _ _) = CmpSymbol a b -type instance ShowTE ('Att l t) = Text "Attribute " :<>: Text l- :<>: Text ":"- :<>: ShowTE t -type instance ShowTE ('Prd l nt) = ShowTE nt :<>: Text "::Production "- :<>: Text l-type instance ShowTE ('Chi l p s) = ShowTE p :<>: Text "::Child " :<>: Text l - :<>: Text ":" :<>: ShowTE s+type instance ShowTE ('Att l t) = Text ("(" `AppendSymbol` l+ `AppendSymbol` ":" `AppendSymbol` FromEM(ShowTE t) `AppendSymbol`+ ")")++type instance ShowTE ('Prd l nt) = Text ( "(" `AppendSymbol` l+ `AppendSymbol` " of " `AppendSymbol` FromEM (ShowTE nt)+ `AppendSymbol` ")")++type instance ShowTE ('Chi l p s) = Text ("Child " `AppendSymbol` l+ `AppendSymbol` " of producion " `AppendSymbol` FromEM (ShowTE p))+ type instance ShowTE ('Left l) = ShowTE l type instance ShowTE ('Right r) = ShowTE r-type instance ShowTE ('NT l) = Text "Non-Terminal " :<>: Text l-type instance ShowTE ('T l) = Text "Terminal " :<>: ShowTE l-+type instance ShowTE ('NT l) = Text ("Non-Terminal " `AppendSymbol` l)+type instance ShowTE ('T l)+ = Text ("Terminal " `AppendSymbol` FromEM (ShowTE l)) +--type instance ShowLabel (l :: Symbol) = l+--type instance ShowLabel (c :: k) = FromEM (ShowTE c) -- | * Records @@ -78,7 +86,7 @@ -- | Type level show utilities type instance ShowRec Reco = "Record"-type instance ShowField Reco = "field named "+type instance ShowField Reco = "field" type Tagged = TagField Reco@@ -136,7 +144,7 @@ -- | type level utilities type instance ShowRec AttReco = "Attribution"-type instance ShowField AttReco = "attribute named "+type instance ShowField AttReco = "attribute" -- | Pattern Synonyms -- pattern EmptyAtt :: Attribution '[]@@ -184,8 +192,6 @@ Text "on " :<>: ShowTE r ] in req prctx (OpLookup @_ @(AttReco) l attr)-- -- * Children
src/Language/Grammars/AspectAG/TH.hs view
@@ -27,10 +27,11 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-} + module Language.Grammars.AspectAG.TH where import Language.Haskell.TH-import Language.Haskell.TH.Syntax (showName)+import Language.Haskell.TH.Syntax (showName, location, Loc(..), Q, Exp, lift) import Data.Proxy import Data.Either import GHC.TypeLits@@ -38,7 +39,8 @@ import Data.Set (Set) import qualified Data.Set as S -import Control.Monad+import Control.Monad +import Language.Haskell.TH.Ppr (pprint) import Data.GenRec.Label import Data.GenRec@@ -46,7 +48,9 @@ import Language.Grammars.AspectAG.RecordInstances import qualified Data.Kind as DK +import Debug.Trace.LocationTH + -- * Attribute labels -- | makes a type level lit (Symbol) from a String@@ -88,15 +92,6 @@ = return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))] --- * Productions---data Symbol = N String | Te Name-type family Terminal s :: Either NT T where- Terminal s = 'Right ('T s)--type family NonTerminal s where- NonTerminal s = 'Left s-- data SymTH = Ter Name | NonTer Name | Poly @@ -277,3 +272,10 @@ mkSemFuncs = liftM concat . sequence . map (mkSemFunc) ++here :: Q Exp+here = location >>= \loc -> [e| Proxy @( Text $(str2Sym . ppLoc $ loc) ) |]+ where+ ppLoc (Loc file _pack mod (line, startcol) (_line', endcol)) =+ " location: (module: " ++ mod ++ ", line:" ++ show line+ ++ " cols: " ++ show (startcol, endcol) ++ ")"
+ src/Language/Grammars/AspectAG/THGen.hs view
@@ -0,0 +1,53 @@+{-|+Module : Language.Grammars.AspectAG+Description : Main module, First-class attribute grammars+Copyright : (c) Juan García-Garland, Marcos Viera, 2019, 2020+License : GPL+Maintainer : jpgarcia@fing.edu.uy+Stability : experimental+Portability : POSIX+-}++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Grammars.AspectAG.THGen where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Data.Proxy+import GHC.TypeLits++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.TH++-- mkMsgPos :: Label ('Att att v) -> Label ('Prd prd nt) -> Proxy pos+-- -> Proxy (Text att :<>: Text " definition in production "+-- :<>:Text prd :<>: Text pos)+-- mkMsgPos Label Label Proxy = Proxy++-- synLoc att prd def =+-- let loc = $(proxyLoc) in+-- traceRule (mkMsgPos att prd (seq loc loc)) $+-- syndefM att prd def