{-# OPTIONS -fcontext-stack=100 #-} {-# LANGUAGE Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction, GADTs, RankNTypes #-} module LangExt where import Control.Arrow import UU.Pretty import Language.Grammars.AspectAG import Language.Grammars.AspectAG.Derive import Language.Grammars.Murder import Language.Grammars.Grammar import Language.Grammars.Grammar.AspectAG import LangSem import Utils import Control.Applicative import Data.HList.Label4 import Data.HList.TypeEqGeneric1 import Data.HList.TypeCastGeneric1 import Language.AbstractSyntax.TTTAS (match, Equal(..)) import Debug.Trace -- modifications of the semantics synM = synmodM inhM = inhmodM --Syntax Macro 1 -------------------------------------------------------------- type AttExpr = Record (HCons (LVPair (Proxy Att_ienv) [(String,Int)]) HNil) -> Record (HCons (LVPair (Proxy Att_spp) PP_Doc) (HCons (LVPair (Proxy Att_sval) Int) HNil)) --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 --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' = agMacro (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 --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` agMacro (aspMul , ch_me1 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2) <.> ch_me2 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2)) semAddSq = semP_AddSq aspAddSq --Parenthesis -- $(chLabel "pe" ''T_Expr) $(addProd "Par" [ ("pe",''T_Expr) ]) sppPar = syn spp $ do pe <- at ch_pe return $ "(" >|< pe # spp >|< ")" svalPar = syn sval $ do liftM (# sval) (at ch_pe) ienvPar = copy ienv exprNT aspPar = sppPar `ext` ienvPar `ext` svalPar -- semPar = \e -> knit aspPar (e .*. emptyRecord) semPar = semP_Par aspPar --Substitution sppSubst = synM spp $ do lnm <- valAt ch_lnm val <- at ch_val body <- at ch_body return $ (body # spp) >|< "[" >|< (pp lnm) >|< " | " >|< (val # spp) >|< "]" semSubst = \b l v -> semP_Let (sppSubst `ext` aspLet) l v b --Grammar Extension {- prds' :: ( NTRecord (nts env) , GetNT NTExp (nts env) (Symbol AttExpr TNonT env) , GetNT NTTerm (nts env) (Symbol AttExpr TNonT env) , GetNT NTFactor (nts env) (Symbol AttExpr TNonT env)) => GramExt env start nts start nts -} {- prds' = proc imported -> do let exp = getNT ntExp imported let term = getNT ntTerm imported let factor = getNT ntFactor imported addProds -< (exp, ( iI semSubst exp "[" var "|" exp "]" Ii)) addProds -< (term, ( iI semSq "square" factor Ii) <|> ( iI semPyth "pyth" factor factor Ii) <|> ( iI semAddSq "addsq" factor factor Ii)) addProds -< (factor, ( iI semPar "(" exp ")" Ii ) ) exportNTs -< imported -} prds' = proc imported -> do let exp = getNT ntExp imported let term = getNT ntTerm imported let factor = getNT ntFactor imported unary <- Language.Grammars.Murder.addNT -< ( iI semSq "square" factor Ii) <|> ( iI semPyth "pyth" factor factor Ii) <|> ( iI semAddSq "addsq" factor factor Ii) <|> ( iI factor Ii ) updProds -< (term, mapNTProds factor unary ) addProds -< (exp, ( iI semSubst exp "[" var "|" exp "]" Ii)) addProds -< (factor, ( iI semPar "(" exp ")" Ii ) ) exportNTs -< imported mapNTProds :: Symbol b TNonT env -> Symbol b TNonT env -> PreProductions TL env a -> PreProductions TL env a mapNTProds s1 s2 (PP prds) = PP $ map (mapNTProd s1 s2) prds mapNTProd :: Symbol b TNonT env -> Symbol b TNonT env -> Prod TL a env -> Prod TL a env mapNTProd r1 r2 (Star f g) = Star (mapNTProd r1 r2 f) (mapNTProd r1 r2 g) mapNTProd (Nont r1) (Nont r2) (Sym (Nont r)) = case match r1 r of (Just Eq) -> Sym (Nont r2) _Nothing -> Sym (Nont r) mapNTProd _ _ p = p --gramOpts' gramOpts = gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]" --Syntax Macro 2 -------------------------------------------------------------- --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' = agMacro (aspMul , ch_me1 ==> (aspCst, ch_cv ~~> (DTerm undefined 2)) <.> 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 --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` agMacro (aspAdd , ch_ae1 --> ch_am1 <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_am2 <.> ch_me2 --> ch_am3)) -- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord) semAddMul = semP_AddMul aspAddMul --Grammar Extension {- prds'' :: ( NTRecord (nts env) , GetNT NTTerm (nts env) (Symbol AttExpr TNonT env) , GetNT NTFactor (nts env) (Symbol AttExpr TNonT env)) => GramExt env start nts start nts -} prds'' = proc imported -> do let term = getNT ntTerm imported let factor = getNT ntFactor imported addProds -< (term, (iI semDb "double" factor Ii) <|> (iI semAddMul "addmul" factor factor factor Ii)) exportNTs -< imported --gramOpts'' gramOpts = gramOpts `extKeywordsTxt` [ "double", "addmul" ] `extSpecChars` "()[|]"