diff --git a/AspectAG.cabal b/AspectAG.cabal --- a/AspectAG.cabal +++ b/AspectAG.cabal @@ -1,5 +1,5 @@ name: AspectAG -version: 0.1.3 +version: 0.1.4 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 + diff --git a/src/Data/AspectAG.hs b/src/Data/AspectAG.hs --- a/src/Data/AspectAG.hs +++ b/src/Data/AspectAG.hs @@ -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