SyntaxMacros-0.2: examples/LangExt.hs

{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction #-}

module LangExt where


import Control.Arrow

import UU.Pretty

import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive

import Language.Grammars.SyntaxMacros
import Language.Grammars.Grammar


import LangSem
import Utils

import Data.HList.Label4
import Data.HList.TypeEqGeneric1
import Data.HList.TypeCastGeneric1


-- modifications of the semantics
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)


$(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)




$(chLabel "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

   
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) >|< "]" 

semSubst r = knit (sppSubst `ext` aspLet) r



--extended grammar (syntax macro) 

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))


prds'  ::    ( NTRecord (nts env) 
             , GetNT NTExp    (nts env)  (Symbol AttExpr TNonT env)
             , GetNT NTFactor (nts env)  (Symbol AttExpr TNonT env)) 
       =>    SyntaxMacro env (Export start nts) (Export start nts)
prds' = proc (Export root nts) -> do
         let exp     = getNT ntExp     nts
         addProds   -<  (exp,     [  prd semSq    $ trm "square"  <.> ch_se<=>exp <.> prdEnd
                                  ,  prd semPyth  $ trm "pyth" <.> ch_pe1<=>exp <.> ch_pe2<=>exp <.> prdEnd
                                  ,  prd semSubst $ ch_body<=>exp <.> trm "[" <.> ch_lnm<=>var <.> 
                                                    trm "|" <.> ch_val<=>exp <.> trm "]"  <.> prdEnd    ])
 

         let factor  = getNT ntFactor  nts
         addProds   -<  (factor,  [  prd semPar $ trm "(" <.> ch_pe<=>exp <.> trm ")" <.>  prdEnd  ])
         
         exportNTs  -< (Export root nts)

gramOpts' gramOpts = gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]"