diff --git a/.AspectAG.cabal.swp b/.AspectAG.cabal.swp new file mode 100644 Binary files /dev/null and b/.AspectAG.cabal.swp differ diff --git a/AspectAG.cabal b/AspectAG.cabal --- a/AspectAG.cabal +++ b/AspectAG.cabal @@ -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, diff --git a/examples/LangExt.old b/examples/LangExt.old new file mode 100644 --- /dev/null +++ b/examples/LangExt.old @@ -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 + +-} diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 +