SemT1.hs

{-# OPTIONS -fcontext-stack=100 #-}
{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}

module Language.Oberon0.L1.SemT1 where

import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive
import Language.Grammars.Grammar (DTerm(..))

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

import UU.Pretty

import Language.Oberon0.L1.Decl 


---- T1(L1) Pretty-Printing

instance Show IntCmp where
 show ECmp = "="; show NECmp = "#"; show LCmp = "<"; show LECmp = "<="; show GCmp = ">"; show GECmp = ">="

instance Show IntBOp where
 show Plus = "+"; show Minus = "-"; show Times = "*"; show Div = "DIV"; show Mod = "MOD"

instance Show IntUOp where
 show Ng = "-"; show Ps = "+"

instance Show BoolBOp where
 show Or = "OR"; show And = "&"

instance Show BoolUOp where
 show Not = "~"



$(attLabels ["spp","sppl","sidl"])

sppNT =   nt_Module .*. nt_Declarations .*. nt_Type .*. nt_Decl .*. nt_Expression .*. hNil 

sppRule = use spp sppNT (>-<) empty 


sppModule = syn spp $ do  idbgn <- at ch_idbgn_Module 
                          decls <- at ch_decls_Module
                          stmts <- at ch_stmts_Module
                          idend <- at ch_idend_Module

			  let ppstmts = case (stmts # sppl) of
						[]  -> empty
						pps -> pp_block "BEGIN " "" ";" pps


                          return $ "MODULE" >#< value idbgn >|< ";" >-< 
                                   decls # spp >-<
                                   ppstmts >-<
                                   "END" >#< value idend >|< "."


sppDeclarations  = syn spp $ do  cst <- at ch_cstdecl_Declarations
		  	         typ <- at ch_typdecl_Declarations
			         var <- at ch_vardecl_Declarations
			         let ppdecl decl kw = case (decl # sppl) of
						        []  -> empty
						        pps -> pp_block kw "" " " pps
                                 return $ ppdecl cst "CONST " >-< ppdecl typ "TYPE  " >-< ppdecl var "VAR   " 



sppCstDecl = syn spp $ do id  <- at ch_id_CstDecl
                          exp <- at ch_exp_CstDecl
                          return $ value id >#< "=" >#< exp # spp >|< ";"



sppTypDecl = syn spp $ do id  <- at ch_id_TypDecl
                          typ <- at ch_typ_TypDecl
                          return $ value id >#< "=" >#< typ # spp >|< ";"


sppVarDecl = syn spp $ do idl <- at ch_idl_VarDecl
                          typ <- at ch_typ_VarDecl
                          return $ case (map pp (idl # sidl)) of
                                    []    -> empty
                                    ppidl -> pp_block "" "" ", " ppidl >#< ":" >#< typ # spp >|< ";"




sppType  = syn spp $ do  id <- at ch_id_Type
                         return $ pp (value id)



sppIntCmpExp = syn spp $ do  op <- at ch_op_IntCmpExp
                             e1 <- at ch_e1_IntCmpExp
                             e2 <- at ch_e2_IntCmpExp
                             return $ e1 # spp >#< show op >#< e2 # spp

sppIntBOpExp = syn spp $ do  op <- at ch_op_IntBOpExp
                             e1 <- at ch_e1_IntBOpExp
                             e2 <- at ch_e2_IntBOpExp
                             return $ e1 # spp >#< show op >#< e2 # spp

sppIntUOpExp = syn spp $ do  op <- at ch_op_IntUOpExp
                             e  <- at ch_e_IntUOpExp
                             return $ show op >#< e # spp


sppBoolBOpExp = syn spp $ do  op <- at ch_op_BoolBOpExp
                              e1 <- at ch_e1_BoolBOpExp
                              e2 <- at ch_e2_BoolBOpExp
                              return $ e1 # spp >#< show op >#< e2 # spp

sppBoolUOpExp = syn spp $ do  op <- at ch_op_BoolUOpExp
                              e  <- at ch_e_BoolUOpExp
                              return $ show op >#< e # spp


sppIdExp  = syn spp $ do  i <- at ch_id_IdExp
                          return $ pp (value i)

sppIntExp = syn spp $ do  i <- at ch_int_IntExp
                          return $ pp (value i)

sppBoolExp = syn spp $ do  b <- at ch_bool_BoolExp
                           return $ pp (if value b then "TRUE" else "FALSE")

sppParExp = syn spp $ do  e <- at ch_e_ParExp
                          return $ "(" >|< e # spp >|< ")"



-- sppl

spplNT = nt_DeclL .*. nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*.  nt_MaybeElseStmt .*. hNil
spplRule = use sppl spplNT (++) [] 

spplDeclL_Cons = syn sppl $ do  hd  <- at ch_hd_DeclL_Cons
	  	    	        tl  <- at ch_tl_DeclL_Cons
                                return $ (hd # spp) : (tl # sppl)

spplDeclL_Nil = syn sppl $ do  return $ []


spplAssigStmt = syn sppl $ do id   <- at ch_id_AssigStmt
                              exp  <- at ch_exp_AssigStmt
                              return $ [ value id >#< ":=" >#< exp # spp ]


spplIfStmt = syn sppl $ do  if_   <- at ch_if_IfStmt
                            elsif <- at ch_elsif_IfStmt
                            els   <- at ch_else_IfStmt
                            let ppelsif = vlist $ map (" ELS" >|<) (elsif # sppl)
	 		    let ppels = case (els # sppl) of
			 		[]  -> empty
			 		pps -> pp_block " ELSE " "" ";" pps
                            return $ [ if_ # sppl >-< ppelsif >-< ppels >-< "END" ]

spplCondStmt = syn sppl $ do  exp  <- at ch_exp_CondStmt
                              ss   <- at ch_ss_CondStmt
                              return $ [  "IF" >#< exp # spp >#< 
                                          pp_block " THEN " "" ";" (ss # sppl) ]


spplWhileStmt = syn sppl $ do  exp  <- at ch_exp_WhileStmt
                               ss   <- at ch_ss_WhileStmt
                               return $ [ "WHILE" >#< exp # spp >#< 
                                          pp_block " DO " " END " ";" (ss # sppl) ]


spplSeqStmt = syn sppl $ do  s1  <- at ch_s1_SeqStmt
                             s2  <- at ch_s2_SeqStmt
                             return $ s1 # sppl ++ s2 # sppl


-- sidl

sidlNT = nt_IdentL .*. hNil
sidlRule = use sidl sidlNT (++) [] 

sidlIdentL_Cons = syn sidl $ do h <- at ch_hd_IdentL_Cons
                                t <- at ch_tl_IdentL_Cons
                                return $  (value h) : (t # sidl)  




---- Aspects
aspModule                 = sppModule 
aspDecls                  = sppDeclarations 
aspDeclL_Cons         	  = spplDeclL_Cons
aspDeclL_Nil         	  = spplDeclL_Nil
aspCstDecl                = sppCstDecl
aspTypDecl                = sppTypDecl
aspVarDecl                = sppVarDecl

aspType                   = sppType

aspAssigStmt              = spplAssigStmt 
aspIfStmt                 = spplIfStmt 
aspWhileStmt              = spplWhileStmt
aspSeqStmt                = spplRule

aspEmptyStmt              = spplRule
 
aspCondStmtL_Cons         = spplRule 
aspCondStmtL_Nil          = spplRule 
aspCondStmt               = spplCondStmt 

aspMaybeElseStmt_Just     = spplRule 
aspMaybeElseStmt_Nothing  = spplRule 


aspIntCmpExp              = sppIntCmpExp 
aspIntBOpExp              = sppIntBOpExp 
aspIntUOpExp              = sppIntUOpExp 

aspBoolBOpExp             = sppBoolBOpExp 
aspBoolUOpExp             = sppBoolUOpExp 

aspIdExp                  = sppIdExp   

aspIntExp                 = sppIntExp   
aspBoolExp                = sppBoolExp   
aspParExp                 = sppParExp   


aspIdentL_Cons            = sidlIdentL_Cons
aspIdentL_Nil             = sidlRule 



---- Semantic Functions

 
l1t1 = mkL1  aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons 
             aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt 
             aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp 
             aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp 
             aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt