AspectAG 0.3.4 → 0.3.4.1
raw patch · 4 files changed
+428/−2 lines, 4 filesdep −haskell98binary-added
Dependencies removed: haskell98
Files
- .AspectAG.cabal.swp binary
- AspectAG.cabal +2/−2
- examples/LangExt.old +315/−0
- examples/Main.hs +111/−0
+ .AspectAG.cabal.swp view
binary file changed (absent → 12288 bytes)
AspectAG.cabal view
@@ -1,5 +1,5 @@ name: AspectAG -version: 0.3.4+version: 0.3.4.1 cabal-version: >= 1.2.3 license: LGPL license-file: COPYRIGHT@@ -14,7 +14,7 @@ extra-source-files: README, LICENSE-LGPL 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+ build-depends: base>=4 && <5, 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,
+ examples/LangExt.old view
@@ -0,0 +1,315 @@+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}++module Main where++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++import Data.Maybe++import UU.Pretty++import Control.Monad +++data AGItf = AGItf { expr :: T_Expr}+ deriving Show++data T_Expr = Cst {cv :: Int}+ | Var {vnm :: String}+ | Mul {me1 :: T_Expr, me2 :: T_Expr}+ | Add {ae1 :: T_Expr, ae2 :: T_Expr}+ | Let {lnm :: String, val :: T_Expr, body :: T_Expr}+ deriving Show++++syn = syndefM+inh = inhdefM+++$(deriveAG ''AGItf)++exprNT = nt_T_Expr .*. hNil+allNT = nt_AGItf .*. exprNT+ ++$(attLabels ["spp"])++sppAGItf = syn spp $ liftM (# spp) (at ch_expr)+sppCst = syn spp $ liftM pp (at ch_cv)+sppVar = syn spp $ liftM pp (at ch_vnm)+sppMul = syn spp $ do e1 <- at ch_me1 + e2 <- at ch_me2+ return $ e1 # spp >|< " * " >|< e2 # spp +sppAdd = syn spp $ do e1 <- at ch_ae1 + e2 <- at ch_ae2+ return $ e1 # spp >|< " + " >|< e2 # spp ++sppLet = syn spp $ do lnm <- at ch_lnm+ val <- at ch_val+ body <- at ch_body+ return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp +++$(attLabels ["ienv","sval"])+++ienvRule = copy ienv exprNT +ienvAGItf = inh ienv exprNT $ do return (ch_expr .=. ([] :: [(String,Int)]) .*. emptyRecord)+ienvCst = ienvRule+ienvVar = ienvRule+ienvMul = ienvRule+ienvAdd = ienvRule+ienvLet = inh ienv exprNT $ do lnm <- at ch_lnm+ val <- at ch_val+ lhs <- at lhs+ return $ ch_val .=. lhs # ienv .*.+ ch_body .=. (lnm, val # sval) : lhs # ienv .*. + emptyRecord+++svalRule f = use sval allNT f (0::Int) +svalAGItf = svalRule ((*)::Int->Int->Int)+svalCst = syn sval $ liftM id (at ch_cv)+svalVar = syn sval $ do vnm <- at ch_vnm + lhs <- at lhs+ return $ fromJust (lookup vnm (lhs # ienv)) +svalMul = svalRule ((*)::Int->Int->Int)+svalAdd = svalRule ((+)::Int->Int->Int)+svalLet = syn sval $ liftM (# sval) (at ch_body)+++aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf+aspCst = sppCst `ext` ienvCst `ext` svalCst +aspVar = sppVar `ext` ienvVar `ext` svalVar +aspMul = sppMul `ext` ienvMul `ext` svalMul +aspAdd = sppAdd `ext` ienvAdd `ext` svalAdd +aspLet = sppLet `ext` ienvLet `ext` svalLet+++semAGItf = semP_AGItf aspAGItf +semCst = semP_Cst aspCst +semVar = semP_Var aspVar +semMul = semP_Mul aspMul+semAdd = semP_Add aspAdd+semLet = semP_Let aspLet +++ex1Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semAdd (semVar $ sem_Lit "x") (semCst $ sem_Lit 3)) ++eval ex = do+ let res = ex (ienv .=. [] .*. emptyRecord)+ print $ res # spp+ print $ res # sval++ex1 = eval ex1Expr+++-- modifications of the semantics+synM = synmodM+inhM = inhmodM+++ +--Square+-- $(chLabel "se" ''T_Expr)+$(addProd "Sq" [ ("se",''T_Expr) ])++sppSq = synM spp $ do me1 <- at ch_se + return $ "square" >#< (me1 # spp) ++se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord)+++-- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)+aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord))++-- semSq = \s -> knit aspSq (s .*. emptyRecord) +semSq = semP_Sq aspSq++++ex2Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semSq (semVar $ sem_Lit "x")) ++ex2 = eval ex2Expr+++--Pyth+-- $(chLabels ["pe1","pe2"] ''T_Expr)+$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])++sppSq' = synM spp $ do liftM (# spp) (at ch_se) +aspSq' = sppSq' `ext` aspSq ++sppPyth = synM spp $ do pe1 <- at ch_pe1+ pe2 <- at ch_pe2 + return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp) +{-+aspAdd' = graft (graft aspAdd+ (ch_ae2 .=. ch_ae2 .*. emptyRecord)+ ch_ae1 + aspSq' + (ch_se .=. ch_pe1 .*. emptyRecord))+ (ch_pe1 .=. ch_pe1 .*. emptyRecord)+ ch_ae2+ aspSq' + (ch_se .=. ch_pe2 .*. emptyRecord)+-}+{-+aspAdd' = macro aspAdd $ ch_ae1 ==> (aspSq', ch_se .=. ch_pe1 .*. emptyRecord)+ <.> + ch_ae2 ==> (aspSq', ch_se .=. ch_pe2 .*. emptyRecord)+-}+aspAdd' = macro aspAdd $ ch_ae1 ==> (aspSq', ch_se --> ch_pe1)+ <.> + ch_ae2 ==> (aspSq', ch_se --> ch_pe2)++aspPyth = sppPyth `ext` aspAdd'+-- semPyth = \p1 p2 -> knit aspPyth (p1 .*. p2 .*. emptyRecord) +semPyth = semP_Pyth aspPyth++ex3Expr = semLet (sem_Lit "x") (semCst $ sem_Lit 2) + (semPyth (semVar $ sem_Lit "x") (semCst $ sem_Lit 3) ) ++ex3 = eval ex3Expr++{-+--AddSq+$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])+++sppAddSq = synM spp $ do as1 <- at ch_as1+ as2 <- at ch_as2 + return $ "addsq" >#< (as1 # spp) >#< (as2 # spp) ++++{-+aspAddSq = sppAddSq `ext`+ (graft (graft aspMul+ (ch_me2 .=. ch_me2 .*. emptyRecord)+ ch_me1 + aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+ (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)+ ch_me2+ aspAdd + (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+-}++aspAddSq = sppAddSq `ext`+ (macro aspMul $ ch_me1 ==> (aspAdd, ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord)+ <.>+ ch_me2 ==> (aspAdd, ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+++semAddSq = semP_AddSq aspAddSq++ex4Expr = (semAddSq (semCst $ sem_Lit 2) (semCst $ sem_Lit 3) ) ++ex4 = eval ex4Expr+++--Double+-- $(chLabel "de" ''T_Expr)+$(addProd "Db" [ ("de",''T_Expr) ])++aspTwo = fixCst aspCst ch_cv 2+{-+aspMul' = graft aspMul+ (ch_me2 .=. ch_de .*. emptyRecord) + ch_me1+ aspTwo+ emptyRecord +-}++aspMul' = macro aspMul $ ch_me1 ==> (aspTwo, emptyRecord)+ <.>+ ch_me2 --> ch_de + ++sppDb = synM spp $ do de <- at ch_de + return $ "double" >#< (de # spp) ++aspDb = sppDb `ext` aspMul'+ +--semDb = \d -> knit aspDb (d .*. emptyRecord)+semDb = semP_Db aspDb+ ++ex5Expr = (semAdd (semCst $ sem_Lit 2) (semDb (semCst $ sem_Lit 3)) ) ++ex5 = eval ex5Expr++++--AddMul+-- $(chLabels ["am1","am2","am3"] ''T_Expr)+$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("am3",''T_Expr) ])+++sppAddMul = synM spp $ do am1 <- at ch_am1 + am2 <- at ch_am2 + am3 <- at ch_am3 + return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp) +{-+aspAddMul = ext sppAddMul $ graft aspAdd+ (ch_ae1 .=. ch_am1 .*. emptyRecord)+ ch_ae2 + aspMul+ (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)+-}+aspAddMul = sppAddMul `ext`+ (macro aspAdd $ ch_ae1 --> ch_am1+ <.>+ ch_ae2 ==> (aspMul, ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord))++ +-- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)+semAddMul = semP_AddMul aspAddMul ++ex6Expr = (semAddMul (semCst $ sem_Lit 2) (semCst $ sem_Lit 3) (semCst $ sem_Lit 4)) ++ex6 = eval ex6Expr+++--LetX+$(addProd "LetX" [ {-("valx",''T_Expr),-} ("bodyx",''T_Expr) ])+++sppLetX = synM spp $ do -- valx <- at ch_valx+ bodyx <- at ch_bodyx+ return $ "x =" >#< {-(valx # spp)-} "10" >#< "=>" >#< (bodyx # spp) ++{-+aspLet' = fixCst aspLet ch_lnm "x"++aspLetX = sppLetX `ext` (mapChildren aspLet' (ch_val .=. ch_valx .*. ch_body .=. ch_bodyx .*. emptyRecord))+-} ++aspLetX = sppLetX `ext` + (macro aspLet $ ch_lnm ~~> "x" <.>+ ch_val ~~> (sval .=. 10 .*. spp .=. "10" .*. emptyRecord) <.> -- --> ch_valx <.> + ch_body --> ch_bodyx) ++semLetX = semP_LetX aspLetX+ ++ex7Expr = (semLetX {-(semCst $ sem_Lit 10)-} (semDb (semVar $ sem_Lit "x")) ) ++ex7 = eval ex7Expr++++main = ex1 >> ex2 >> ex3 >> ex4 >> ex5 >> ex6 >> ex7++-}
+ examples/Main.hs view
@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright :+-- License : AllRightsReserved+--+-- Maintainer :+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}++module Main where+++import Language.Grammars.AspectAG+import Language.Grammars.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]+type EList = [Expression]++data Expression+ = Application { eFn :: Expression, eArgs :: EList }+ | Atom { eAtom :: String }+ | Lambda { eFormalArgs :: StringList, eBody :: Expression }+ | Constant { eConst :: WrapConst }+++$(deriveAG ''Definition)++fromListEList = foldr ConsEList NilEList++$(attLabels ["xerror", "diLevel", "xerror2"])+++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+