AspectAG 0.1.4 → 0.1.5

raw patch · 4 files changed

+41/−18 lines, 4 files

Files

• AspectAG.cabal +1/−1
• examples/calcM.hs +1/−0
• src/Data/AspectAG.hs +9/−11
• src/Data/AspectAG/Derive.hs +30/−6

@@ -1,5 +1,5 @@ name:               AspectAG -version:            0.1.4+version:            0.1.5 license:            LGPL license-file:       COPYRIGHT maintainer:         Marcos Viera <mviera@fing.edu.uy>

@@ -94,3 +94,4 @@ exval = sem_AGItf (asp_sval () .+. asp_ienv ()) (AGItf ex) () # sval excnt = sem_AGItf (asp_ccount ()) (AGItf ex)  (ccount .=. 0 .*. emptyRecord) # ccount +

@@ -78,9 +78,9 @@ --   It takes a label 'att' representing the name of the attribute, 
 --   a value 'val' to be assigned to this attribute, and it builds a function which 
 --   updates the output constructed thus far.
-synmod  ::  (HUpdateAtHNat n (Att att val) sp sp', HFind att ls n, RecordLabels sp ls) 
-        =>  att -> val -> Fam ic (Record sp) -> Fam ic (Record sp')
-synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v)
+synmod  ::  HUpdateAtLabel att val sp sp' 
+        =>  att -> val -> Fam ic sp -> Fam ic sp' 
+synmod att v (Fam ic sp) = Fam ic (hUpdateAtLabel att v sp) 
 
 -- | The function 'inhdef' introduces a new inherited attribute for 
 --   a collection of non-terminals.
@@ -218,28 +218,25 @@  singlemod = undefined
 
 
-instance  ( HasField lch ic (Record och)
-          , HUpdateAtHNat n (Att att vch) och och', HFind att ls n, RecordLabels och ls  -- HExtend (Att att vch) och och'
-          , HUpdateAtLabel lch (Record och') ic ic') 
+instance  ( HasField lch ic och
+          , HUpdateAtLabel att vch och och'
+          , HUpdateAtLabel lch och' ic ic') 
       => SingleMod  HTrue HTrue att (Chi lch vch) ic ic' 
   where singlemod _ _ att pch ic = 
-           hUpdateAtLabel lch (och .@. att .=. vch ) ic  
+           hUpdateAtLabel lch (hUpdateAtLabel att vch och) ic  
            where  lch  = labelLVPair  pch
                   vch  = valueLVPair  pch
                   och  = hLookupByLabel lch ic 
 
 
 
--- (HUpdateAtHNat n (Att att val) sp sp', HFind att ls n, RecordLabels sp ls) 
---         =>  att -> val -> Fam ic (Record sp) -> Fam ic (Record sp')
-
-
 -- | Composition of two rules.
 ext ::  Rule sc ip ic' sp' ic'' sp'' -> Rule sc ip ic sp ic' sp'
     -> Rule sc ip ic sp ic'' sp''  
 ext f g input = f input . g input
 
 
+
 -- Monadic Interface 
 
 data Lhs
@@ -775,6 +772,7 @@     where
      n    = hFind l (recordLabels rec)
      r'   = hUpdateAtHNat n (newLVPair l v) r
+
 
 
 sndProxy :: Proxy (a,b) -> Proxy b

@@ -1,7 +1,7 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS -XEmptyDataDecls #-} -module Data.AspectAG.Derive (deriveAG, attLabel, attLabels, typeList) where+module Data.AspectAG.Derive (deriveAG, attLabel, attLabels, chLabel, chLabels, typeList) where  import Language.Haskell.TH @@ -37,10 +37,19 @@ attLabels ::  [String] -> Q [Dec] attLabels = liftM concat . mapM attLabel +chLabel ::  String -> Name -> Q [Dec]+chLabel n t = chLabels [n] t -chLabels ::  [Name] -> [Type] -> Q [Dec]-chLabels ns ts = (liftM concat) $ zipWithM label ns ts+chLabels ::  [String] -> Name -> Q [Dec]+chLabels ns t = (liftM concat) $ mapM (label t . mkName) ns   where+      label t n = declareLabel (chTName n) (chName n) (tyLabel (chTName n) t) +      tyLabel n t = appT (appT (conT $ mkName "(,)") (conT n)) (conT t) +++chLabels2 ::  [Name] -> [Type] -> Q [Dec]+chLabels2 ns ts = (liftM concat) $ zipWithM label ns ts+  where       label n t = declareLabel (chTName n) (chName n) (tyLabel (chTName n) t)        tyLabel n t = appT (appT (conT $ mkName "(,)") (conT n)) (return t)  @@ -86,7 +95,7 @@       body <- [| knit ($(aspV) # $(att cn)) $(childs cht chn conargs) |]        let semF = Clause (pat cn conargs) (NormalB body) []       lp <- declareLabel (prdTName cn) (prdName cn) (conT $ prdTName cn)-      lc <- chLabels chn cht+      lc <- chLabels2 chn cht       return ((stn',lp++lc++decl'),semF:fc)   where      newNames []     = return []@@ -115,7 +124,7 @@   -+#if __GLASGOW_HASKELL__ < 6012  getUserType :: Info -> Q UserType getUserType info = do     case info of@@ -125,6 +134,21 @@             _                               -> scopeError         _ -> scopeError     where scopeError = error $ "Can only be used on algebraic datatypes"+#endif++#if __GLASGOW_HASKELL__ >= 6012+getUserType :: Info -> Q UserType+getUserType info = do+    case info of+        TyConI d -> case d of+            (DataD     _ uname args cs  _)  -> return $ UserD uname (map f args) cs +            (NewtypeD  _ uname args c   _)  -> return $ UserD uname (map f args) [c]+            _                               -> scopeError+        _ -> scopeError+    where scopeError = error $ "Can only be used on algebraic datatypes"+          f (PlainTV n)    = n+          f (KindedTV n _) = n+#endif  getCtx :: Con -> ([Type],[Name], Name)  getCtx (RecC           name args) = (map thd args, map fst' args, name)