oberon0-0.0.1: src/Language/Oberon0/L1/SemT2.hs
{-# OPTIONS -fcontext-stack=100 #-}
{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, ScopedTypeVariables #-}
module Language.Oberon0.L1.SemT2 (module Language.Oberon0.L1.SemT1, module Language.Oberon0.L1.SemT2) where
import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive
import Language.Grammars.Grammar (DTerm(..),Pos(..))
import Data.HList.Label4
import Data.HList.TypeEqGeneric1
import Data.HList.TypeCastGeneric1
import qualified Data.Map as Map
import Language.Oberon0.L1.Decl
import qualified Language.Oberon0.L1.SemT1 as T1
import Language.Oberon0.L1.SemT1 (l1t1,spp,sppl,sidl)
---- T2 (L1) Name binding
$(attLabels ["senv", "ienv", "serr", "spos"])
data SymbolInfo a b = SI a b
deriving Show
data NameDef = NameDef Pos --position
String --type of definition (i.e. Cst, Typ, Var, etc.)
String --description (i.e. constant, type, variable, etc.)
deriving Show
type NInfo a = SymbolInfo NameDef a
-- spos
sposType = syn spos $ do idt <- at ch_id_Type
return $ pos idt
-- senv
senvNT = nt_Declarations .*. nt_DeclL .*. nt_Decl .*. nt_IdentL .*. hNil
senvRule (_ :: a) = use senv senvNT Map.union (Map.empty :: Map.Map String (NInfo a))
senvCstDecl r = syn senv $ do id <- at ch_id_CstDecl
return $ Map.singleton (value id)
(SI (NameDef (pos id) "Cst" "constant") r)
senvTypDecl r = syn senv $ do id <- at ch_id_TypDecl
return $ Map.singleton (value id)
(SI (NameDef (pos id) "Typ" "type") r)
senvIdentL_Cons r = syn senv $ do h <- at ch_hd_IdentL_Cons
t <- at ch_tl_IdentL_Cons
return $ Map.insert (value h)
(SI (NameDef (pos h) "Var" "variable") r)
(t # senv)
-- ienv
ienvNT = nt_Module .*. nt_Declarations .*. nt_Type .*. nt_DeclL .*. nt_Decl .*.
nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_IdentL .*. hNil
ienvRule _ = copy ienv ienvNT
ienvIni r = Map.fromList [("INTEGER", SI (NameDef (Pos (-1) (-1)) "Typ" "type") r)
,("BOOLEAN", SI (NameDef (Pos (-1) (-1)) "Typ" "type") r)
,("TRUE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") r)
,("FALSE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") r)]
ienvModule r = inh ienv ienvNT $ do lhs <- at lhs
decls <- at ch_decls_Module
let env = Map.union (decls # senv) (lhs # ienv)
return $ ch_stmts_Module .=. env .*.
ch_decls_Module .=. env .*.
emptyRecord
ienvCstDecl _ = inh ienv ienvNT $ do lhs <- at lhs
id <- at ch_id_CstDecl
return $ ch_exp_CstDecl .=. ( Map.delete (value id) .
Map.filter (\(SI (NameDef _ knd _) _) -> knd == "Cst") ) (lhs # ienv) .*.
emptyRecord
ienvTypDecl _ = inh ienv ienvNT $ do lhs <- at lhs
id <- at ch_id_TypDecl
return $ ch_typ_TypDecl .=. Map.delete (value id) (lhs # ienv) .*.
emptyRecord
-- serr
serrNT = nt_Module .*. nt_Declarations .*. nt_Type .*. nt_DeclL .*. nt_Decl .*.
nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_IdentL .*. hNil
serrRule = use serr serrNT (++) ([] :: [String])
iferr cond err = if cond then err else []
serrModule = syn serr $ do idbgn <- at ch_idbgn_Module
decls <- at ch_decls_Module
stmts <- at ch_stmts_Module
idend <- at ch_idend_Module
let err = show (pos idend) ++ ": " ++ value idend
let nerr = iferr (value idbgn /= value idend) [ err ++ " sould be the Module name " ++ value idbgn ]
return $ nerr ++ decls # serr ++ stmts # serr
checkName name env expected place =
let fid = value name
err = show (pos name) ++ ": " ++ fid
in case (Map.lookup fid env) of
Just (SI (NameDef p t d) _) -> iferr (not $ elem t expected) [ err ++ " is a " ++ d ++ " identifier (defined at " ++ show p
++ "), so can't be used in " ++ place ]
Nothing -> [ err ++ " is not defined" ]
serrType = syn serr $ do id <- at ch_id_Type
lhs <- at lhs
return $ checkName id (lhs # ienv) ["Typ"] "a type"
serrAssigStmt = syn serr $ do id <- at ch_id_AssigStmt
exp <- at ch_exp_AssigStmt
lhs <- at lhs
return $ checkName id (lhs # ienv) ["Var"] "an assignment" ++ exp # serr
serrIdExp = syn serr $ do id <- at ch_id_IdExp
lhs <- at lhs
return $ checkName id (lhs # ienv) ["Var","Cst"] "an expression"
checkRep name env =
let fid = value name
err = show (pos name) ++ ": " ++ fid
in case (Map.lookup fid env) of
Just (SI (NameDef p _ _) _) -> iferr (p /= (pos name)) [ err ++ " is already defined (at " ++ show p ++ ")" ]
Nothing -> [ ]
serrCstDecl = syn serr $ do id <- at ch_id_CstDecl
exp <- at ch_exp_CstDecl
lhs <- at lhs
return $ checkRep id (lhs # ienv) ++ exp # serr
serrTypDecl = syn serr $ do id <- at ch_id_TypDecl
typ <- at ch_typ_TypDecl
lhs <- at lhs
return $ checkRep id (lhs # ienv) ++ typ # serr
serrIdentL_Cons = syn serr $ do h <- at ch_hd_IdentL_Cons
t <- at ch_tl_IdentL_Cons
lhs <- at lhs
return $ checkRep h (lhs # ienv) ++ t # serr
---- Aspects
aspModule r = (ienvModule r) `ext` serrModule `ext` T1.aspModule
aspDecls r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDecls
aspDeclL_Cons r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDeclL_Cons
aspDeclL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDeclL_Nil
aspCstDecl r = (senvCstDecl r) `ext` (ienvCstDecl r) `ext` serrCstDecl `ext` T1.aspCstDecl
aspTypDecl r = (senvTypDecl r) `ext` (ienvTypDecl r) `ext` serrTypDecl `ext` T1.aspTypDecl
aspVarDecl r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspVarDecl
aspType r = sposType `ext` (ienvRule r) `ext` serrType `ext` T1.aspType
aspAssigStmt r = (ienvRule r) `ext` serrAssigStmt `ext` T1.aspAssigStmt
aspIfStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspIfStmt
aspWhileStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspWhileStmt
aspSeqStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspSeqStmt
aspEmptyStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspEmptyStmt
aspCondStmtL_Cons r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmtL_Cons
aspCondStmtL_Nil r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmtL_Nil
aspCondStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmt
aspMaybeElseStmt_Just r = (ienvRule r) `ext` serrRule `ext` T1.aspMaybeElseStmt_Just
aspMaybeElseStmt_Nothing r = (ienvRule r) `ext` serrRule `ext` T1.aspMaybeElseStmt_Nothing
aspIntCmpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntCmpExp
aspIntBOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntBOpExp
aspIntUOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntUOpExp
aspBoolBOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolBOpExp
aspBoolUOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolUOpExp
aspIdExp r = (ienvRule r) `ext` serrIdExp `ext` T1.aspIdExp
aspIntExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntExp
aspBoolExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolExp
aspParExp r = (ienvRule r) `ext` serrRule `ext` T1.aspParExp
aspIdentL_Cons r = (senvIdentL_Cons r) `ext` (ienvRule r) `ext` serrIdentL_Cons `ext` T1.aspIdentL_Cons
aspIdentL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspIdentL_Nil
---- Semantic Functions
l1t2 = 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 ())