diff --git a/AspectAG.cabal b/AspectAG.cabal --- a/AspectAG.cabal +++ b/AspectAG.cabal @@ -1,5 +1,6 @@ name: AspectAG -version: 0.3 +version: 0.3.1 +cabal-version: >= 1.2.3 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera @@ -10,13 +11,13 @@ category: Development stability: Experimental copyright: Universiteit Utrecht -build-depends: base>=4 && <5, haskell98, template-haskell>=2.4.0.1, HList>=0.2.2, containers>=0.2.0.0, mtl>=1.1.0.2 -cabal-version: >= 1.2.3 -exposed-modules: Language.Grammars.AspectAG, Language.Grammars.AspectAG.Derive -other-modules: -extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, - TypeSynonymInstances, UndecidableInstances, GADTs -hs-source-dirs: src extra-source-files: README, LICENSE-LGPL -ghc-options: -Wall + +library + build-depends: base>=4 && <5, haskell98, template-haskell>=2.4.0.1, HList>=0.2.2, containers>=0.2.0.0, mtl>=1.1.0.2 + exposed-modules: Language.Grammars.AspectAG, Language.Grammars.AspectAG.Derive + extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, + MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, + TypeSynonymInstances, UndecidableInstances, GADTs + hs-source-dirs: src + ghc-options: -Wall diff --git a/src/Language/Grammars/AspectAG.hs b/src/Language/Grammars/AspectAG.hs --- a/src/Language/Grammars/AspectAG.hs +++ b/src/Language/Grammars/AspectAG.hs @@ -35,7 +35,7 @@ inhmodM, synmodM, -- ** Rules Composition - ext, adapt, rename, graft, + ext, adapt, rename, fixCst, graft, -- * Aspects Prd, (.+.), @@ -51,6 +51,9 @@ inhAspect, synAspect, chnAspect, attAspect, defAspect, + -- * Others + ListNT(..), + module Data.HList ) where @@ -266,6 +269,8 @@ och = hLookupByLabel lch ic + + -- Rules Composition @@ -300,12 +305,14 @@ instance ( RenLR s (Record r') (Record r'') , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r') - => RenLR (HCons (lr,lr') s) + => RenLR (HCons (LVPair lr lr') s) (Record r) (Record (HCons (LVPair lr' v) r'')) where - renLR (HCons (lr,lr') s) r = hExtend (newLVPair lr' v) r'' + renLR (HCons lp s) r = hExtend (newLVPair lr' v) r'' where + lr = labelLVPair lp + lr' = valueLVPair lp v = hLookupByLabel lr r r' = hDeleteAtLabel lr r r'' = renLR s r' @@ -319,57 +326,96 @@ instance ( RenRL s (Record r') (Record r'') , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r') - => RenRL (HCons (lr',lr) s) + => RenRL (HCons (LVPair lr' lr) s) (Record r) (Record (HCons (LVPair lr' v) r'')) where - renRL (HCons (lr',lr) s) r = hExtend (newLVPair lr' v) r'' + renRL (HCons lp s) r = hExtend (newLVPair lr' v) r'' where + lr' = labelLVPair lp + lr = valueLVPair lp v = hLookupByLabel lr r r' = hDeleteAtLabel lr r r'' = renRL s r' + +-- | Fixing a constant as a child. +fixCst + :: (RecordLabels r ls, + HRLabelSet (HCons (LVPair l (Record HNil)) r), + HExtend (LVPair l v) t2 l', + HRearrange ls r1 r', + HLabelSet ls, + H2ProjectByLabels (HCons l HNil) t10 t11 r1) => + (Fam t t1 l' t3 + -> Fam t4 t5 (Record (HCons (LVPair l (Record HNil)) r)) t6 + -> Fam t7 t8 (Record t10) t9) + -> l + -> v + -> Fam t t1 t2 t3 + -> Fam t4 t5 (Record r) t6 + -> Fam t7 t8 (Record r') t9 +fixCst rule lch cst (Fam lf hof sc ip) (Fam li hoi ici spi) = + let (Fam lo hoo ico spo) = rule (Fam lf hof (lch .=. cst .*. sc) ip) (Fam li hoi (lch .=. emptyRecord .*. ici) spi) + ls = recordLabels ici + ico' = hRearrange ls (hDeleteAtLabel lch ico) + in (Fam lo hoo ico' spo) + + -- | Grafting one tree as a child of the other. graft - :: (HRLabelSet (HCons (LVPair lch t3) t22), - HasField lch t6 p, - HRLabelSet t22, - HRLabelSet t12, - H2ProjectByLabels ls t5 t12 t22, - RecordLabels r ls, + :: (RecordLabels r ls, + RecordValues r1 vs, + HRLabelSet t2, + HRLabelSet t1, + H2ProjectByLabels vs r t1 t2, + HRLabelSet (HCons (LVPair l (Record HNil)) t2), HRLabelSet t21, HRLabelSet t11, - H2ProjectByLabels ls t4 t11 t21, - HRLabelSet (HCons (LVPair lch (Record HNil)) t21), - HLeftUnion (Record r) (Record t23) r'', - H2ProjectByLabels (HCons lch HNil) t6 t13 t23) - => (Rule lf hof (Record (HCons (LVPair lch t3) t22)) t - l ho (Record (HCons (LVPair lch (Record HNil)) t21)) t1 - l1 ho1 (Record t6) t2) - -> (Rule lf hof (Record t12) p - l1 ho1 (Record t11) (Record HNil) - l2 ho2 (Record r) t3) - -> lch - -> (Rule lf hof (Record t5) t - l ho (Record t4) t1 - l2 ho2 r'' t2) -graft rule1 rule2 lch (Fam lf hof sc ip) (Fam l ho ici spi) = + H2ProjectByLabels vs t t11 t21, + HasField l t6 ip1, + RenLR r1 ico1 t4, + RenRL r1 (Record t1) ici1, + RenRL r1 (Record t11) sc1, + HRLabelSet (HCons (LVPair l t5) t21), + RenLR l' ico (Record t6), + RenRL + l' (Record (HCons (LVPair l (Record HNil)) t2)) ici, + RenRL + l' (Record (HCons (LVPair l t5) t21)) sc, + HExtend (LVPair l l) l1 l', + HLeftUnion t4 (Record t23) (Record r2), + H2ProjectByLabels (HCons l HNil) t6 t13 t23, + HRearrange ls r2 r', + HLabelSet ls) => + Rule lf hof sc ip li hoi ici spi li1 hoi1 ico t12 + -> l1 + -> l + -> Rule lf hof sc1 ip1 li1 hoi1 ici1 (Record HNil) t22 t3 ico1 t5 + -> r1 + -> Fam lf hof (Record t) ip + -> Fam li hoi (Record r) spi + -> Fam t22 t3 (Record r') t12 +graft rule1 chs1 lch rule2 chs2 (Fam lf hof sc ip) (Fam l ho ici spi) = let spi1 = spi spi2 = emptyRecord - ls2 = recordLabels ico2 + ls2 = recordValues (Record chs2) (ici2,ici1') = hProjectByLabels2 ls2 ici ici1 = lch .=. emptyRecord .*. ici1' (sc2,sc1') = hProjectByLabels2 ls2 sc sc1 = lch .=. spo2 .*. sc1' ip1 = ip ip2 = ico1 # lch - (Fam l1 ho1 ico1 spo1) = rule1 (Fam lf hof sc1 ip1) (Fam l ho ici1 spi1) - (Fam l2 ho2 ico2 spo2) = rule2 (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2) - ico = hLeftUnion ico2 (hDeleteAtLabel lch ico1) + + (Fam l1 ho1 ico1 spo1) = (rename rule1 (lch .=. lch .*. chs1)) (Fam lf hof sc1 ip1) (Fam l ho ici1 spi1) + (Fam l2 ho2 ico2 spo2) = (rename rule2 chs2) (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2) + ls = recordLabels ici + ico = hRearrange ls $ hLeftUnion ico2 (hDeleteAtLabel lch ico1) spo = spo1 in (Fam l2 ho2 ico spo) + -- Monadic Interface data Lhs @@ -542,6 +588,15 @@ class SemType t nt | t -> nt + +class ListNT nt tHd tTl where + ch_hd :: Proxy (tHd, nt) + ch_tl :: Proxy (tTl, [nt]) + + ch_hd = proxy + ch_tl = proxy + + -- | A /copy/ rule copies an inherited attribute from the parent to all its children. -- The function 'copy' takes the name of an attribute 'att' and diff --git a/src/Language/Grammars/AspectAG/Derive.hs b/src/Language/Grammars/AspectAG/Derive.hs --- a/src/Language/Grammars/AspectAG/Derive.hs +++ b/src/Language/Grammars/AspectAG/Derive.hs @@ -205,4 +205,3 @@ -