AspectAG 0.3.3 → 0.3.4
raw patch · 4 files changed
+447/−58 lines, 4 files
Files
- AspectAG.cabal +1/−1
- examples/LangDef.hs +115/−0
- examples/LangExt.hs +236/−0
- src/Language/Grammars/AspectAG.hs +95/−57
AspectAG.cabal view
@@ -1,5 +1,5 @@ name: AspectAG -version: 0.3.3+version: 0.3.4 cabal-version: >= 1.2.3 license: LGPL license-file: COPYRIGHT
+ examples/LangDef.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}++module LangDef where++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++import Data.Maybe++import UU.Pretty++import Control.Monad +++data AGItf = AGItf { expr :: T_Expr}+ deriving Show++data T_Expr = Cst {cv :: Int}+ | Var {vnm :: String}+ | Mul {me1 :: T_Expr, me2 :: T_Expr}+ | Add {ae1 :: T_Expr, ae2 :: T_Expr}+ | Let {lnm :: String, val :: T_Expr, body :: T_Expr}+ deriving Show++++syn = syndefM+inh = inhdefM+++$(deriveAG ''AGItf)++exprNT = nt_T_Expr .*. hNil+allNT = nt_AGItf .*. exprNT+ ++$(attLabels ["spp"])++sppAGItf = syn spp $ liftM (# spp) (at ch_expr)+sppCst = syn spp $ liftM pp (at ch_cv)+sppVar = syn spp $ liftM pp (at ch_vnm)+sppMul = syn spp $ do e1 <- at ch_me1 + e2 <- at ch_me2+ return $ e1 # spp >|< " * " >|< e2 # spp +sppAdd = syn spp $ do e1 <- at ch_ae1 + e2 <- at ch_ae2+ return $ e1 # spp >|< " + " >|< e2 # spp ++sppLet = syn spp $ do lnm <- at ch_lnm+ val <- at ch_val+ body <- at ch_body+ return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp +++$(attLabels ["ienv","sval"])+++ienvRule = copy ienv exprNT +ienvAGItf = inh ienv exprNT $ do return (ch_expr .=. ([] :: [(String,Int)]) .*. emptyRecord)+ienvCst = ienvRule+ienvVar = ienvRule+ienvMul = ienvRule+ienvAdd = ienvRule+ienvLet = inh ienv exprNT $ do lnm <- at ch_lnm+ val <- at ch_val+ lhs <- at lhs+ return $ ch_val .=. lhs # ienv .*.+ ch_body .=. (lnm, val # sval) : lhs # ienv .*. + emptyRecord+++svalRule f = use sval allNT f (0::Int) +svalAGItf = svalRule ((*)::Int->Int->Int)+svalCst = syn sval $ liftM id (at ch_cv)+svalVar = syn sval $ do vnm <- at ch_vnm + lhs <- at lhs+ return $ fromJust (lookup vnm (lhs # ienv)) +svalMul = svalRule ((*)::Int->Int->Int)+svalAdd = svalRule ((+)::Int->Int->Int)+svalLet = syn sval $ liftM (# sval) (at ch_body)+++aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf+aspCst = sppCst `ext` ienvCst `ext` svalCst +aspVar = sppVar `ext` ienvVar `ext` svalVar +aspMul = sppMul `ext` ienvMul `ext` svalMul +aspAdd = sppAdd `ext` ienvAdd `ext` svalAdd +aspLet = sppLet `ext` ienvLet `ext` svalLet+++semAGItf = semP_AGItf aspAGItf +semCst = semP_Cst aspCst +semVar = semP_Var aspVar +semMul = semP_Mul aspMul+semAdd = semP_Add aspAdd+semLet = semP_Let aspLet +++ex1Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semAdd (semVar $ sem_Lit "x") (semCst $ sem_Lit 3)) ++eval ex = do+ let res = ex (ienv .=. [] .*. emptyRecord)+ print $ res # spp+ print $ res # sval++ex1 = eval ex1Expr+++
+ examples/LangExt.hs view
@@ -0,0 +1,236 @@+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}++module LangExt where++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++import Data.Maybe++import UU.Pretty++import Control.Monad ++import LangDef+++-- modifications of the semantics+synM = synmodM+inhM = inhmodM+++ +--Square+-- $(chLabel "se" ''T_Expr)+$(addProd "Sq" [ ("se",''T_Expr) ])++sppSq = synM spp $ do me1 <- at ch_se + return $ "square" >#< (me1 # spp) ++se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord)+++-- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)+aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord))++-- semSq = \s -> knit aspSq (s .*. emptyRecord) +semSq = semP_Sq aspSq++++ex2Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semSq (semVar $ sem_Lit "x")) ++ex2 = eval ex2Expr+++--Pyth+-- $(chLabels ["pe1","pe2"] ''T_Expr)+$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])++sppSq' = synM spp $ do liftM (# spp) (at ch_se) +aspSq' = sppSq' `ext` aspSq ++sppPyth = synM spp $ do pe1 <- at ch_pe1+ pe2 <- at ch_pe2 + return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp) +{-+aspAdd' = graft (graft aspAdd+ (ch_ae2 .=. ch_ae2 .*. emptyRecord)+ ch_ae1 + aspSq' + (ch_se .=. ch_pe1 .*. emptyRecord))+ (ch_pe1 .=. ch_pe1 .*. emptyRecord)+ ch_ae2+ aspSq' + (ch_se .=. ch_pe2 .*. emptyRecord)+-}++aspAdd' = agMacro (aspAdd , ch_ae1 ==> (aspSq', ch_se --> ch_pe1) + <.> ch_ae2 ==> (aspSq', ch_se --> ch_pe2))++aspPyth = sppPyth `ext` aspAdd'+-- semPyth = \p1 p2 -> knit aspPyth (p1 .*. p2 .*. emptyRecord) +semPyth = semP_Pyth aspPyth++ex3Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semPyth (semVar $ sem_Lit "x") (semCst $ sem_Lit 3) ) ++ex3 = eval ex3Expr+++--AddSq+$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])+++sppAddSq = synM spp $ do as1 <- at ch_as1+ as2 <- at ch_as2 + return $ "addsq" >#< (as1 # spp) >#< (as2 # spp) ++++{-+aspAddSq = sppAddSq `ext`+ (graft (graft aspMul+ (ch_me2 .=. ch_me2 .*. emptyRecord)+ ch_me1 + aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+ (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)+ ch_me2+ aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+-}++aspAddSq = sppAddSq `ext`+ agMacro (aspMul , ch_me1 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2)+ <.> ch_me2 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2))+++semAddSq = semP_AddSq aspAddSq++ex4Expr = (semAddSq (semCst $ sem_Lit 2) (semCst $ sem_Lit 3) ) ++ex4 = eval ex4Expr+++--Double+-- $(chLabel "de" ''T_Expr)+$(addProd "Db" [ ("de",''T_Expr) ])++aspTwo = fixCst aspCst ch_cv 2+{-+aspMul' = graft aspMul+ (ch_me2 .=. ch_de .*. emptyRecord) + ch_me1+ aspTwo+ emptyRecord +-}++aspMul' = agMacro (aspMul , ch_me1 ==> (aspTwo, flip const)+ <.> ch_me2 --> ch_de)+ ++sppDb = synM spp $ do de <- at ch_de + return $ "double" >#< (de # spp) ++aspDb = sppDb `ext` aspMul'+ +--semDb = \d -> knit aspDb (d .*. emptyRecord)+semDb = semP_Db aspDb+ ++ex5Expr = (semAdd (semCst $ sem_Lit 2) (semDb (semCst $ sem_Lit 3)) ) ++ex5 = eval ex5Expr++++--AddMul+-- $(chLabels ["am1","am2","am3"] ''T_Expr)+$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("am3",''T_Expr) ])+++sppAddMul = synM spp $ do am1 <- at ch_am1 + am2 <- at ch_am2 + am3 <- at ch_am3 + return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp) +{-+aspAddMul = ext sppAddMul $ graft aspAdd+ (ch_ae1 .=. ch_am1 .*. emptyRecord)+ ch_ae2 + aspMul+ (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)+-}+aspAddMul = sppAddMul `ext`+ agMacro (aspAdd , ch_ae1 --> ch_am1+ <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_am2 <.> ch_me2 --> ch_am3))++ +-- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)+semAddMul = semP_AddMul aspAddMul ++ex6Expr = (semAddMul (semCst $ sem_Lit 2) (semCst $ sem_Lit 3) (semCst $ sem_Lit 4)) ++ex6 = eval ex6Expr+++--LetX+$(addProd "LetX" [ {-("valx",''T_Expr),-} ("bodyx",''T_Expr) ])+++sppLetX = synM spp $ do -- valx <- at ch_valx+ bodyx <- at ch_bodyx+ return $ "x =" >#< {-(valx # spp)-} "10" >#< "=>" >#< (bodyx # spp) ++{-+aspLet' = fixCst aspLet ch_lnm "x"++aspLetX = sppLetX `ext` (mapChildren aspLet' (ch_val .=. ch_valx .*. ch_body .=. ch_bodyx .*. emptyRecord))+-} ++aspLetX = sppLetX `ext` + agMacro (aspLet , ch_lnm ~~> "x" <.>+ ch_val ~~> (sval .=. 10 .*. spp .=. "10" .*. emptyRecord) <.> -- --> ch_valx <.> + ch_body --> ch_bodyx) ++semLetX = semP_LetX aspLetX+ ++ex7Expr = (semLetX {-(semCst $ sem_Lit 10)-} (semDb (semVar $ sem_Lit "x")) ) ++ex7 = eval ex7Expr+++--AddMulMul+$(addProd "AddMulSq" [ ("ams1",''T_Expr), ("ams2",''T_Expr), ("ams3",''T_Expr) ])+++sppAddMulSq = + synM spp $ do ams1 <- at ch_ams1 + ams2 <- at ch_ams2 + ams3 <- at ch_ams3 + return $ "addmulsq" >#< (ams1 # spp) >#< (ams2 # spp) >#< (ams3 # spp) ++aspAddMulSq = sppAddMulSq `ext`+ agMacro (aspAdd , ch_ae1 --> ch_ams1+ <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_ams2 <.>+ ch_me2 ==> (aspMul, ch_me1 --> ch_ams3 <.> ch_me2 --> ch_ams3)))+++semAddMulSq = semP_AddMulSq aspAddMulSq ++ex8Expr = semAddMulSq (semCst $ sem_Lit 2) (semCst $ sem_Lit 3) (semCst $ sem_Lit 4)++ex8 = eval ex8Expr+++main = ex1 >> ex2 >> ex3 >> ex4 >> ex5 >> ex6 >> ex7 >> ex8++
src/Language/Grammars/AspectAG.hs view
@@ -36,7 +36,7 @@ -- ** Rules Composition ext, adapt, rename, mapChildren, fixCst, graft, - macro, (==>),(-->), (<.>), + agMacro, (~~>), (==>), (-->), (<.>), -- * Aspects Prd, (.+.), @@ -453,47 +453,64 @@ in (Fam lo hoo ico' spo) -- | Grafting one tree as a child of the other. -graft :: (HExtend (LVPair e e) l s, +graft :: (HasField' b e (HCons (LVPair e v2) a3) v, + HasField' b e (HCons (LVPair e (Record HNil)) a2) v1, HasField e t2 ip1, RecordLabels t ls2, + HEq e e b, HRLabelSet a1, HRLabelSet (HCons (LVPair e (Record HNil)) a2), - HRLabelSet (HCons (LVPair e v) a3), HRLabelSet a3, + HRLabelSet (HCons (LVPair e e) r1), + HRLabelSet (HCons (LVPair e v2) a3), + HRLabelSet (HCons (LVPair e v) r'), + HRLabelSet (HCons (LVPair e v1) r'1), HRLabelSet a2, HRLabelSet a, - MapLR s1 ico1 r1, - MapLR s ico (Record t2), - MapRL s (Record (HCons (LVPair e v) a3)) sc, - MapRL s1 (Record a1) sc1, - MapRL s1 (Record a) ici1, - MapRL s (Record (HCons (LVPair e (Record HNil)) a2)) ici, - H2ProjectByLabels ls t1 a1 b1, - H2ProjectByLabels ls1 t1 a3 b3, + MapLR r ico1 r3, + MapLR (HCons (LVPair e e) r1) ico (Record t2), + MapRL r1 (Record (HCons (LVPair e (Record HNil)) a2)) (Record r'1), + MapRL r (Record a1) sc, + MapRL r (Record a) ici, + MapRL r1 (Record (HCons (LVPair e v2) a3)) (Record r'), + H2ProjectByLabels ls t1 a1 b2, + H2ProjectByLabels ls1 t1 a3 b4, H2ProjectByLabels (HCons e HNil) t2 t3 t4, - H2ProjectByLabels ls1 t a2 b2, - H2ProjectByLabels ls t a b, - HRearrange ls2 r r', - RecordValues l ls1, - RecordValues s1 ls, - HLeftUnion r1 (Record t4) (Record r), + H2ProjectByLabels ls1 t a2 b3, + H2ProjectByLabels ls t a b1, + RecordValues r1 ls1, + RecordValues r ls, + HLeftUnion r3 (Record t4) (Record r2), + HRearrange ls2 r2 r'2, HLabelSet ls2) => - Rule lf hof sc ip li hoi ici spi li1 hoi1 ico p - -> l + Rule + lf + hof + (Record (HCons (LVPair e v) r')) + ip + li + hoi + (Record (HCons (LVPair e v1) r'1)) + spi + li1 + hoi1 + ico + p + -> Record r1 -> e - -> Rule lf hof sc1 ip1 li1 hoi1 ici1 (Record HNil) l1 ho ico1 v - -> s1 + -> Rule lf hof sc ip1 li1 hoi1 ici (Record HNil) l ho ico1 v2 + -> Record r -> Fam lf hof (Record t1) ip -> Fam li hoi (Record t) spi - -> Fam l1 ho (Record r') p + -> Fam l ho (Record r'2) p graft rule1 chs1 lch rule2 chs2 (Fam lf hof sc ip) (Fam l ho ici spi) = let spi1 = spi spi2 = emptyRecord -- ls1' and ls2 don't need to be disjoint - ls1' = recordValues (Record chs1) - ls2 = recordValues (Record chs2) + ls1' = recordValues chs1 + ls2 = recordValues chs2 ici1' = hProjectByLabels ls1' ici ici2 = hProjectByLabels ls2 ici ici1 = lch .=. emptyRecord .*. ici1' @@ -514,64 +531,83 @@ -- | A generalized version of 'graft' that grafts into or maps every children. -macro :: (RecordLabels r ls, HRearrange ls r1 r', HLabelSet ls) => - (Fam l1 ho1 c p1 -> Fam l ho c1 p -> Fam t t1 t2 p2) - -> ((l1, ho1, c2, Record r) - -> (t, t1, t2, Record HNil, Record HNil) - -> (l2, ho2, Record r1, c1, c)) +agMacro :: (RecordLabels r ls, HRearrange ls r1 r', HLabelSet ls) => + ( (Fam l1 ho1 c p1 -> Fam l ho c1 p -> Fam t t1 t2 p2) + , ((l1, ho1, c2, Record r) + -> (t, t1, t2, Record HNil, Record HNil) + -> (l2, ho2, Record r1, c1, c))) -> Fam l1 ho1 c2 p1 -> Fam l ho (Record r) p -> Fam l2 ho2 (Record r') p2 -macro rule1 chRules (Fam lf hof sc ip) (Fam l ho ici spi) = +agMacro (rule1, chMap) (Fam lf hof sc ip) (Fam l ho ici spi) = let spi1 = spi ip1 = ip (Fam l1 ho1 ico1 spo1) = rule1 (Fam lf hof sc1 ip1) (Fam l ho ici1 spi1) - (l2, ho2, ico, ici1, sc1) = chRules (lf, hof, sc, ici) (l1, ho1, ico1, emptyRecord, emptyRecord) + (l2, ho2, ico, ici1, sc1) = chMap (lf, hof, sc, ici) (l1, ho1, ico1, emptyRecord, emptyRecord) ls = recordLabels ici ico' = hRearrange ls ico spo = spo1 in (Fam l2 ho2 ico' spo) + +infixr 4 ~~> + +-- | Child mapping definition, it reads /replaced by the constant/. +(~~>) :: (HExtend (LVPair e (Record HNil)) l1 t9, + HExtend (LVPair e v) l t10, + H2ProjectByLabels (HCons e HNil) t4 t5 t6) => + e + -> v + -> (t, t1, t2, t3) + -> (t7, t8, Record t4, l1, l) + -> (t7, t8, Record t6, t9, t10) + +lch ~~> cst = \(_, _, _, _) (l1,ho1,ico1,ici1,sc1) -> + let ico1' = hDeleteAtLabel lch ico1 + ici1' = lch .=. emptyRecord .*. ici1 + sc1' = lch .=. cst .*. sc1 + in (l1, ho1, ico1', ici1', sc1') + + + + +infixr 4 ==> + -- | Child mapping definition, it reads /replaced by/. -(==>) :: (HExtend (LVPair l2 v) l1 t10, - HExtend (LVPair l2 (Record HNil)) l t9, - HasField l2 t3 ip, - HRLabelSet a1, - HRLabelSet a, - MapLR s ico r, - MapRL s (Record a) ici, - MapRL s (Record a1) sc, - H2ProjectByLabels ls t2 a1 b1, - H2ProjectByLabels (HCons l2 HNil) t3 t4 t5, - H2ProjectByLabels ls t1 a b, - RecordValues s ls, - HLeftUnion r (Record t5) t8) => - l2 - -> (Rule lf hof sc ip li hoi ici (Record HNil) t6 t7 ico v, s) - -> (lf, hof, (Record t2), Record t1) - -> (li, hoi, Record t3, l, l1) - -> (t6, t7, t8, t9, t10) +(==>) :: (HExtend (LVPair l3 v) l2 t14, + HExtend (LVPair l3 (Record HNil)) l t13, + HasField l3 t7 p, + H2ProjectByLabels (HCons l3 HNil) t7 t8 t9, + HLeftUnion r (Record t9) t12) => + l3 + -> (Fam t t1 c p -> Fam l1 ho c1 (Record HNil) -> Fam t4 t5 t6 v, + (t, t1, t2, t3) + -> (t4, t5, t6, Record HNil, Record HNil) + -> (t10, t11, r, c1, c)) + -> (t, t1, t2, t3) + -> (l1, ho, Record t7, l, l2) + -> (t10, t11, t12, t13, t14) lch ==> (rule2, chMap) = \(lf, hof, sc, ici) (l1,ho1,ico1,ici1,sc1) -> let spi2 = emptyRecord - ls2 = recordValues (Record chMap) - ici2 = hProjectByLabels ls2 ici - sc2 = hProjectByLabels ls2 sc - ip2 = ico1 # lch - (Fam l2 ho2 ico2 spo2) = (mapChildren rule2 chMap) (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2) - - ico1' = hLeftUnion ico2 (hDeleteAtLabel lch ico1) + (Fam l2 ho2 ico2 spo2) = rule2 (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2) + + (l2', ho2', ico2', ici2, sc2) = chMap (lf, hof, sc, ici) (l2, ho2, ico2, emptyRecord, emptyRecord) + + ico1' = hLeftUnion ico2' (hDeleteAtLabel lch ico1) ici1' = lch .=. emptyRecord .*. ici1 sc1' = lch .=. spo2 .*. sc1 - in (l2, ho2, ico1', ici1', sc1') + in (l2', ho2', ico1', ici1', sc1') + +infixr 4 --> -- | Child mapping definition, it reads /binds to/. (-->) :: (HExtend (LVPair e v1) l1 t10, @@ -592,6 +628,8 @@ ici1' = lch .=. (ici # lch2) .*. ici1 sc1' = lch .=. (sc # lch2) .*. sc1 in (l1, ho1, ico1', ici1', sc1') + +infixr 2 <.> -- | Composition of children mapping definitions for the function 'macro'. (<.>) :: ((lf,hof,sc,ici) -> (l2,ho2,ico1',ici1',sc1') -> (l3,ho3,ico1'',ici1'',sc1''))