AspectAG 0.3.5 → 0.3.6

raw patch · 2 files changed

+70/−3 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• AspectAG.cabal +1/−1
• src/Language/Grammars/AspectAG.hs +69/−2

@@ -1,5 +1,5 @@ name:               AspectAG -version:            0.3.5+version:            0.3.6 cabal-version:      >= 1.2.3   license:            LGPL license-file:       COPYRIGHT

@@ -26,7 +26,7 @@               instdef, locdef,
               inhdef, syndef, 
               inhmod, synmod,
-              {-inhupd,-} synupd,
+              inhupd, synupd,
 
               -- ** Monadic
 
@@ -34,7 +34,7 @@               instdefM, locdefM,
               inhdefM, syndefM, inh, syn,
               inhmodM, synmodM,
-              {-inhupdM,-} synupdM,
+              inhupdM, synupdM,
 
               -- ** Rules Composition
               ext, adapt, rename, mapChildren, fixCst, graft,
@@ -129,6 +129,8 @@ synmod att v (Fam l ho ic sp) = Fam l ho ic (hUpdateAtLabel att v sp) 
 
 
+synupd  :: (HasField att sp val, HUpdateAtLabel att val' sp sp') 
+        => att -> (val -> val') -> Fam l ho ic sp -> Fam l ho ic sp'
 synupd att f (Fam l ho ic sp) =  r'
                                where  v  =  f (sp # att)
                                       r' =  Fam l ho ic (hUpdateAtLabel att v sp) 
@@ -281,8 +283,70 @@                   och  = hLookupByLabel lch ic 
 
 
+-------------------------------------------------------------------------------
+inhupd  ::  Upds att nts vals ic ic' 
+        =>  att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
+inhupd att nts vals (Fam l ho ic sp) = 
+        Fam l ho (upds att nts vals ic) sp
 
 
+
+class Upds att nts vals ic ic'  | vals ic -> ic' where
+  upds :: att -> nts -> vals -> ic -> ic'
+
+instance Upds att nts (Record HNil) ic ic where
+  upds _ _ _ ic = ic
+
+instance  ( Upds att nts (Record vs) ic ic'
+          , HasLabel (Proxy (lch,t)) ic' mch
+          , HMember (Proxy t) nts mnts
+          , SingleUpd  mch mnts att 
+                  (Chi (Proxy (lch,t)) vch) 
+                  ic' ic'' ) 
+      => Upds  att nts 
+               (Record (HCons  (Chi (Proxy (lch,t)) vch) vs)) 
+               ic ic'' 
+      where 
+  upds att nts ~(Record (HCons pch vs)) ic = 
+         singleupd mch mnts att pch ic'  
+         where  ic'     = upds att nts (Record vs) ic
+                lch     = labelLVPair pch
+                mch     = hasLabel lch ic'
+                mnts    = hMember (sndProxy lch) nts
+
+
+
+class  SingleUpd mch mnts att pv ic ic' 
+       | mch mnts pv ic -> ic' 
+  where singleupd :: mch -> mnts -> att -> pv -> ic -> ic'
+
+
+data IncorrectUpd l lch err
+
+instance Fail (IncorrectUpd l lch (UndefNT t)) 
+         => SingleUpd HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
+ singleupd = undefined
+
+instance Fail (IncorrectUpd l lch (UndefProd (lch,t))) 
+         => SingleUpd HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
+ singleupd = undefined
+
+
+instance  ( HasField lch ic och
+          , HasField att och vch
+          , HUpdateAtLabel att vch' och och'
+          , HUpdateAtLabel lch och' ic ic') 
+      => SingleUpd  HTrue HTrue att (Chi lch (vch->vch')) ic ic' 
+  where singleupd _ _ att pch ic = 
+           hUpdateAtLabel lch (hUpdateAtLabel att vch' och) ic  
+           where  lch  = labelLVPair  pch
+                  fch  = valueLVPair  pch
+                  och  = hLookupByLabel lch ic 
+                  vch' = fch (och # att)
+
+
+-------------------------------------------------------------------------------
+
 -- Rules Composition
 
 
@@ -763,6 +827,9 @@          =>  att -> nts -> Reader (Fam lf hof sc ip) a 
          ->  Rule lf hof sc ip l ho ic sp l ho ic' sp
 inhmodM att nts d inp  = inhmod att nts (def d inp) 
+
+inhupdM att nts d inp  = inhupd att nts (def d inp) 
+
 
 
 synmodM  ::  (HUpdateAtHNat n (Att att a) sp sp',HFind att ls n,RecordLabels sp ls)