AspectAG 0.1.3 → 0.1.4

raw patch · 3 files changed

+256/−25 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• AspectAG.cabal +1/−1
• examples/Main.hs +114/−0
• src/Data/AspectAG.hs +141/−24

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

@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+--+-- Module      :  Main+-- Copyright   :+-- License     :  AllRightsReserved+--+-- Maintainer  :+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}++module Main where+++import Data.AspectAG+import Data.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++-- data DefinitionList+--    = DLCons { dlHd :: Definition, dlTl :: DefinitionList } | DLNil { dlNil :: () }+++data Const+    =   ConstString String+    |   ConstInt    Int+    |   ConstChar   Char+    deriving(Show, Eq)++type WrapConst = Const+type StringList = [String]++$(typeList "EList" "Expression")+fromListEList = foldr ConsEList NilEList -- could be generated by typeList++data Definition+    =   Definition {+            dName       :: String+    ,       dArgs       :: StringList+    ,       dExpression :: Expression+    ,       dWhere      :: DefinitionList+    }  ++type DefinitionList = [Definition]++data Expression+    =   Application { eFn :: Expression, eArgs :: EList }+    |   Atom { eAtom :: String }+    |   Lambda { eFormalArgs :: StringList, eBody :: Expression }+    |   Constant { eConst :: WrapConst }+++$(deriveAG ''Definition)++$(attLabels ["xerror", "diLevel", "xerror2"])++{-+processChildList children = map (\ex -> sem_Expression (asp_xerror ()) ex emptyRecord) children++processArgs eArgs = do+    return $ foldr (\x l -> "o" : (x # xerror) ++ l) [] $ processChildList eArgs+-}++asp_xerrorD () = synAspect xerror (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)+        ((++)::[String] -> [String] -> [String])  ([]::[String])+        ( p_Application .*. p_Definition .*. p_Atom .*. p_Lambda .*. p_Constant .*. hNil ) $ -- use rule+        emptyRecord++-- could also be generated by typeList+asp_foldrEList f s = synAspect xerror (nt_EList .*. nt_Expression .*. hNil)+                f  s+                (p_ConsEList .*. p_NilEList .*. hNil)+                emptyRecord+++asp_xerror () = asp_xerrorD () .+. asp_foldrEList ((\lhd ltl -> "o" : lhd ++ ltl)::[String] -> [String] -> [String]) ([]::[String])++asp_xerror2 () = synAspect xerror2 (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)+        ((++)::[String] -> [String] -> [String])  ([]::[String])+        ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_ConsEList .*. p_NilEList .*. hNil ) $ -- use rule+        p_Definition .=. (def $ at lhs >>= \lhs -> do return [show $ lhs # diLevel ]) .*.+        emptyRecord++{-+asp_diLevel () = inhAspect diLevel ( nt_Expression .*. hNil ) ( p_Application .*. p_Lambda .*. hNil ) $+    p_Definition .=. (def $ at lhs >>= \lhs -> return $ (ch_dExpression .=. (lhs # diLevel) + 1) .*. emptyRecord)+    .*. emptyRecord+-}+++ex :: Expression+ex = Application (Lambda ["foo"] (Atom "x")) $ fromListEList $ map (Constant . ConstInt) [2, 2, 5]++dd = Definition {+        dName = "bar"+    ,   dArgs = ["x", "y"]+    ,   dExpression = ex+    ,   dWhere = []+    }++sem1 = sem_Definition (asp_xerror  ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror+sem2 = sem_Definition (asp_xerror2 ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror2++sem3 = sem_Definition (asp_xerror () .+. asp_xerror2 ())  dd (diLevel .=. 55 .*. emptyRecord) # xerror2++main = print sem1 >> print sem2 >> print sem3+

@@ -20,8 +20,15 @@ 
               -- * Rules
               Att, Fam(..), Chi, Rule, 
-              inhdef, syndef, ext,
+              inhdef, syndef, 
+              inhmod, synmod,
+              ext,
 
+              -- ** Monadic
+              At(..), lhs, def,
+              inhdefM, syndefM,
+              inhmodM, synmodM,
+
               -- * Aspects
               Prd, (.+.),
 
@@ -34,7 +41,6 @@               -- * Defining Aspects
               inhAspect, synAspect, chnAspect,
               attAspect, defAspect,
-              At(..), lhs, def,
 
               module Data.HList
             ) where
@@ -68,6 +74,14 @@         =>  att -> val -> (Fam ic sp -> Fam ic sp')
 syndef  att val (Fam ic sp) = Fam  ic (att .=. val .*. sp)
 
+-- | The function 'synmod' modifies the definition of a synthesized attribute.
+--   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)
+
 -- | The function 'inhdef' introduces a new inherited attribute for 
 --   a collection of non-terminals.
 --   It takes the following parameters:
@@ -83,7 +97,7 @@         Fam (defs att nts vals ic) sp
 
 
--- | The class 'Def' is defined by induction over the record 'vals' 
+-- | The class 'Defs' is defined by induction over the record 'vals' 
 --   containing the new definitions. 
 --   The function 'defs' inserts each definition into the attribution 
 --   of the corresponding child. 
@@ -140,11 +154,135 @@                   vch  = valueLVPair  pch
                   och  = hLookupByLabel lch ic 
 
+
+
+
+-- | The function 'inhmod' modifies an inherited attribute for 
+--   a collection of non-terminals.
+--   It takes the following parameters:
+--     'att': the attribute which is being defined,
+--     'nts': the non-terminals with which this attribute is being associated, and
+--     'vals': a record labelled with child names and containing values, 
+--              describing how to compute the attribute being defined at each 
+--              of the applicable child  positions.
+--   It builds a function which updates the output constructed thus far.||
+inhmod  ::  Mods att nts vals ic ic' 
+        =>  att -> nts -> vals -> (Fam ic sp -> Fam ic' sp)
+inhmod att nts vals (Fam ic sp) = 
+        Fam (mods att nts vals ic) sp
+
+
+
+-- | The class 'Mods' is defined by induction over the record 'vals' 
+--   containing the new definitions. 
+--   The function 'mods' inserts each definition into the attribution 
+--   of the corresponding child. 
+class Mods att nts vals ic ic'  | vals ic -> ic' where
+  mods :: att -> nts -> vals -> ic -> ic'
+
+instance Mods att nts (Record HNil) ic ic where
+  mods _ _ _ ic = ic
+
+instance  ( Mods att nts (Record vs) ic ic'
+          , HasLabel (Proxy (lch,t)) ic' mch
+          , HMember (Proxy t) nts mnts
+          , SingleMod  mch mnts att 
+                  (Chi (Proxy (lch,t)) vch) 
+                  ic' ic'' ) 
+      => Mods  att nts 
+               (Record (HCons  (Chi (Proxy (lch,t)) vch) vs)) 
+               ic ic'' 
+      where 
+  mods att nts ~(Record (HCons pch vs)) ic = 
+         singlemod mch mnts att pch ic'  
+         where  ic'     = mods att nts (Record vs) ic
+                lch     = labelLVPair pch
+                mch     = hasLabel lch ic'
+                mnts    = hMember (sndProxy lch) nts
+
+
+
+class  SingleMod mch mnts att pv ic ic' 
+       | mch mnts pv ic -> ic' 
+  where singlemod :: mch -> mnts -> att -> pv -> ic -> ic'
+
+
+data IncorrectMod l lch err
+
+instance Fail (IncorrectMod l lch (UndefNT t)) 
+         => SingleMod HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
+ singlemod = undefined
+
+instance Fail (IncorrectMod l lch (UndefProd (lch,t))) 
+         => SingleMod HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
+ 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') 
+      => SingleMod  HTrue HTrue att (Chi lch vch) ic ic' 
+  where singlemod _ _ att pch ic = 
+           hUpdateAtLabel lch (och .@. att .=. vch ) 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
+lhs :: Proxy Lhs
+lhs = proxy 
+
+class At l m v | l -> v where
+  at :: l -> m v
+
+instance (HasField (Proxy (lch,nt)) chi v, MonadReader (Fam chi par) m) 
+       => At (Proxy (lch,nt)) m v where
+  at lbl = liftM (\(Fam chi _) -> chi # lbl) ask
+
+instance MonadReader (Fam chi par) m
+       => At (Proxy Lhs) m par where
+  at _ = liftM (\(Fam _ par) -> par) ask
+
+def :: Reader (Fam chi par) a -> ((Fam chi par) -> a)
+def = runReader
+
+
+
+inhdefM  :: (Defs att nts a ic ic') 
+         => att-> nts-> Reader (Fam sc ip) a -> Rule sc ip ic sp ic' sp
+inhdefM att nts d f  = inhdef att nts (def d f)
+
+
+syndefM  :: (HExtend (Att att a) sp sp') 
+         =>  att-> Reader (Fam sc ip) a -> Rule sc ip ic sp ic sp'
+syndefM att d f      = syndef att (def d f)
+
+
+inhmodM  ::  (Mods att nts a ic ic') 
+         =>  att -> nts -> Reader (Fam sc ip) a -> Rule sc ip ic sp ic' sp
+inhmodM att nts d f  = inhmod att nts (def d f)
+
+
+synmodM  :: (HUpdateAtHNat n (Att att a) sp sp',HFind att ls n,RecordLabels sp ls) 
+         => att-> Reader (Fam sc ip) a -> Rule sc ip ic (Record sp) ic (Record sp') 
+synmodM att v f      = synmod att (def v f)
+
+
+
 -- | Field of an aspect. It associates a production 'prd' with a rule 'rule'.
 type Prd prd rule = LVPair prd rule
 
@@ -613,27 +751,6 @@           ,  TypeCast (Rule sc ip ic sp ic' sp') r) 
       => Poly   (FnChn att nts) r where 
   poly (FnChn att nts) = typeCast $ chain att nts
-
-
------- 
-
-data Lhs
-lhs :: Proxy Lhs
-lhs = proxy 
-
-class At l m v | l -> v where
-  at :: l -> m v
-
-instance (HasField (Proxy (lch,nt)) chi v, MonadReader (Fam chi par) m) 
-       => At (Proxy (lch,nt)) m v where
-  at lbl = liftM (\(Fam chi _) -> chi # lbl) ask
-
-instance MonadReader (Fam chi par) m
-       => At (Proxy Lhs) m par where
-  at _ = liftM (\(Fam _ par) -> par) ask
-
-def :: Reader (Fam chi par) a -> ((Fam chi par) -> a)
-def = runReader
 
 
 ------ HList