{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction
, GADTs #-}
module Expr 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 att d f = syndef att (def d f)
-- inh att nts d f = inhdef att nts (def d f)
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 e = knit aspAGItf (ch_expr .=. e .*. emptyRecord)
semCst e = knit aspCst (ch_cv .=. (\(Record HNil) -> e) .*. emptyRecord)
semVar e = knit aspVar (ch_vnm .=. (\(Record HNil) -> e) .*. emptyRecord)
semMul e1 e2 = knit aspMul (ch_me1 .=. e1 .*. ch_me2 .=. e2 .*. emptyRecord)
semAdd e1 e2 = knit aspAdd (ch_ae1 .=. e1 .*. ch_ae2 .=. e2 .*. emptyRecord)
semLet l e1 e2 = knit aspLet (ch_lnm .=. (\(Record HNil) -> l) .*. ch_val .=. e1 .*. ch_body .=. e2 .*. emptyRecord)
-}
semAGItf r = knit aspAGItf r
semCst r = knit aspCst r
semVar r = knit aspVar r
semMul r = knit aspMul r
semAdd r = knit aspAdd r
semLet = knit aspLet
-- modifications
-- syn att d f = syndef att (def d f)
-- inh att nts d f = inhdef att nts (def d f)
-- synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v)
-- synM att v f = synmod att (def v f)
synM = synmodM
inhM = inhmodM
$(chLabel "se" ''T_Expr)
sppSq = synM spp $ do me1 <- at ch_me1
return $ "square " >|< (me1 # spp)
semSq r = knit (sppSq `ext` aspMul)
(ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)
{-
sppSq = synM spp $ do me1 <- at ch_me1
return $ "square " >|< (me1 # spp)
semSq r = knit (sppSq `ext` aspMul) (ch_me2 .=. (r # ch_me1) .*. r)
-}
$(chLabels ["pe1","pe2"] ''T_Expr)
sppPyth = synM spp $ do ae1 <- at ch_ae1
ae2 <- at ch_ae2
return $ "pyth " >|< (ae1 # spp) >|< " "
>|< (ae2 # spp)
svalPyth = synM sval $ do ae1 <- at ch_ae1
ae2 <- at ch_ae2
return $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval)
semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd)
(ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord)
-- identity stuff
$(chLabel "pe" ''T_Expr)
{-
synId att = syn att $ liftM (# att) (at ch_id)
inhId att nts = inh att nts $ do lhs <- at lhs
return $ ch_id .=. (lhs # att) .*. emptyRecord
attsId = (synId spp) `ext`(inhId ienv exprNT) `ext`(synId sval)
-}
sppPar = syn spp $ do pe <- at ch_pe
return $ "(" >|< pe # spp >|< ")"
svalPar = syn sval $ do liftM (# sval) (at ch_pe)
ienvPar = copy ienv exprNT
semPar = knit (sppPar `ext` ienvPar `ext` svalPar)
sppSubst = synM spp $ do lnm <- at ch_lnm
val <- at ch_val
body <- at ch_body
return $ (body # spp) >|< "[" >|< (pp lnm) >|< " | " >|< (val # spp) >|< "]"
{-
ienvSubst = inhM 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
-}
semSubst r = knit (sppSubst `ext` {-ienvSubst `ext`-} aspLet) r