SyntaxMacros-1.0: examples/LangExt.hs

{-# OPTIONS -fcontext-stack=100 #-}
{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction,
    RankNTypes #-}

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 Control.Applicative

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



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

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)
semSq = \s -> knit aspSq (s .*. emptyRecord)  


--Pyth
$(chLabels ["pe1","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 .*. hNil)
                          ch_ae1 
                          aspSq' 
                          (ch_se .=. ch_pe1 .*. hNil))
                  (ch_pe1 .=. ch_pe1 .*. hNil)
                  ch_ae2
                  aspSq' 
                  (ch_se .=. ch_pe2 .*. hNil)

aspPyth    = sppPyth `ext` aspAdd'
semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  
                

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

aspPar = sppPar `ext` ienvPar `ext` svalPar
   
semPar = \e -> knit aspPar (e .*. emptyRecord)


--Substitution
sppSubst = synM spp $ do  lnm   <- at ch_lnm
                          val   <- at ch_val
                          body  <- at ch_body
                          return $ (body # spp) >|< "[" >|< (pp lnm)  >|< " | " >|< (val # spp) >|< "]" 

semSubst = \l v b -> knit (sppSubst `ext` aspLet) (l .*. v .*. b .*. emptyRecord)




--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)) 
       =>    SyntaxMacro 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  (ch_body <=> exp) "[" (ch_lnm <=> var) "|" (ch_val <=> exp) "]" Ii))

         addProds   -<  (term,    ( iI semSq     "square"  (ch_se  <=> factor) Ii) <|>
                                  ( iI semPyth   "pyth"    (ch_pe1 <=> factor) (ch_pe2 <=> factor) Ii))
 
         addProds   -<  (factor,  ( iI semPar    "(" (ch_pe <=> exp) ")" Ii )    )
         
         exportNTs  -< imported



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



--Syntax Macro 2 --------------------------------------------------------------

--Double
$(chLabel "de" ''T_Expr)

aspTwo = fixCst aspCst ch_cv 2

aspMul' =  graft  aspMul
                  (ch_me2 .=. ch_de .*. hNil) 
                  ch_me1
                  aspTwo
                  hNil 

sppDb = synM spp $ do de <- at ch_de 
                      return $ "double" >#< (de # spp)   

aspDb = sppDb `ext` aspMul'
                
semDb = \d -> knit aspDb (d .*. emptyRecord)

           


--AddMul
$(chLabels ["am1","am2","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 .*. hNil)
                                    ch_ae2 
                                    aspMul
                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. hNil)
 
semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)
                          


--Grammar Extension

prds''  ::    ( NTRecord (nts env) 
              , GetNT NTTerm   (nts env)  (Symbol AttExpr TNonT env)
              , GetNT NTFactor (nts env)  (Symbol AttExpr TNonT env)) 
       =>    SyntaxMacro env start nts start nts
prds'' = proc imported -> do
         let term    = getNT ntTerm    imported
         let factor  = getNT ntFactor  imported


         addProds   -<  (term,     (iI semDb      "double"  (ch_de   <=> factor) Ii) <|>
                                   (iI semAddMul  "addmul"  (ch_am1  <=> factor) (ch_am2  <=> factor) (ch_am3  <=> factor) Ii))

         
         exportNTs  -< imported



gramOpts'' gramOpts = gramOpts `extKeywordsTxt` [ "double", "addmul" ] `extSpecChars` "()[|]"