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

module Language.Oberon0.L1.SemT5 (module Language.Oberon0.L1.SemT5, module Language.Oberon0.L1.SemT3) 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.C

import Language.Oberon0.L1.Decl 

import qualified Language.Oberon0.L1.SemT3 as T3
import Language.Oberon0.L1.SemT3 (l1t1,l1t2,l1t3,spp,sidl,senv,ienv,serr,spos,sty,sterr,check
                ,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType)

---- T5(L1) Code Generation


compStmt s1 s2 =  let  c1 = case s1 of
                                        CCompound _ cbl _ -> cbl
                                        cb                -> [ CBlockStmt cb ]
                       c2 = case s2 of
                                        CCompound _ cbl _ -> cbl
                                        cb                -> [ CBlockStmt cb ]
 
                  in   CCompound [] (c1 ++ c2) undefNode


mapIdent sid env = internalIdent $ maybe sid (\(SI _ (SI _ (SI i _))) -> i) (Map.lookup sid env) 


$(attLabels ["scgen","scdecl","scty","scexp","scstmt","ipre"])


-- ipre

ipreNT =   nt_Declarations .*. nt_DeclL .*. nt_Decl .*.
           nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_Type .*. hNil 

ipreRule = copy ipre ipreNT

-- top-level definitions prefixed by: _<module name>_ 
-- no c reserved word starts with _
ipreModule = inh ipre ipreNT $ do id <- at ch_idbgn_Module
                                  return $ ch_stmts_Module .=. ("_" ++ value id ++ "_") .*.
                                           ch_decls_Module .=. ("_" ++ value id ++ "_") .*.
                                           emptyRecord 

-- senv

senvNT = T3.senvNT

updMap ni r (SI nd (SI ti _)) = (SI nd (SI ti (SI ni r)))

senvCstDecl' r = synupdM senv $ do lhs  <- at lhs
                                   id   <- at ch_id_CstDecl
                                   let cid = value id
                                   return $ Map.adjust (updMap (lhs # ipre ++ cid) r) cid
                                                        

senvTypDecl' r = synupdM senv $ do lhs  <- at lhs
                                   id   <- at ch_id_TypDecl
                                   let tid = value id
                                   return $ Map.adjust (updMap (lhs # ipre ++ tid) r) tid
                                         

senvVarDecl' r = synupdM senv $ do lhs  <- at lhs
                                   return $ Map.mapWithKey (\k -> updMap (lhs # ipre ++ k) r)  

-- ienv

ienvNT = T3.ienvNT

ienvIni r = Map.fromList [("INTEGER", SI (NameDef (Pos (-1) (-1)) "Typ" "type")     (SI intType  (SI "int" r)))
                         ,("BOOLEAN", SI (NameDef (Pos (-1) (-1)) "Typ" "type")     (SI boolType (SI "int" r))) 
                         ,("TRUE",    SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType (SI "int" r)))
                         ,("FALSE",   SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType (SI "int" r)))] 


ienvModule' r = inhmodM 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 

-- scgen

scgenNT =   nt_Module .*.  hNil 

scgenModule = syn scgen $ do idbgn <- at ch_idbgn_Module 
                             decls <- at ch_decls_Module
                             stmts <- at ch_stmts_Module
                             idend <- at ch_idend_Module
                             let mainfun = [ CFDefExt (CFunDef [CTypeSpec (CIntType undefNode)]
                                                               (CDeclr (Just $ (internalIdent "main")) 
                                                                       [CFunDeclr (Right ([],False)) [] undefNode] 
                                                                       Nothing [] undefNode) 
                                                               []
                                                               (compStmt (stmts # scstmt) 
                                                                         (CReturn (Just (CConst (CIntConst (cInteger 0) undefNode))) undefNode ))
                                                               undefNode) 
                                           ]
                             return $ CTranslUnit (decls # scdecl ++  mainfun) undefNode

-- scdecl

scdeclNT = nt_Declarations .*. nt_DeclL .*. nt_Decl .*. hNil

scdeclRule = use scdecl scdeclNT (++) ([] :: [CExternalDeclaration NodeInfo]) 

scdeclCstDecl = syn scdecl $ do lhs <- at lhs
                                id  <- at ch_id_CstDecl
                                exp <- at ch_exp_CstDecl
                                return [ CDeclExt $
                                         CDecl  [CTypeSpec (CEnumType (CEnum Nothing (Just [( mapIdent (value id) (lhs # ienv), Just (exp # scexp))]) 
                                                                             [] 
                                                                             undefNode) 
                                                                      undefNode)]
                                                [ ] 
                                                undefNode
                                       ]


scdeclTypDecl = syn scdecl $ do lhs <- at lhs 
                                id  <- at ch_id_TypDecl
                                typ <- at ch_typ_TypDecl
                                let (tys,tyd) = typ # scty
                                return [ CDeclExt $
                                         CDecl [CStorageSpec (CTypedef undefNode), tys]
                                               [ ( Just (CDeclr (Just $ mapIdent (value id) (lhs # ienv)) tyd Nothing [] undefNode), Nothing, Nothing)] 
                                               undefNode
                                       ] 


scdeclVarDecl = syn scdecl $ do lhs <- at lhs
                                idl <- at ch_idl_VarDecl
                                typ <- at ch_typ_VarDecl
                                let (tys,tyd) = typ # scty
                                let vars = map (\name -> (Just (CDeclr (Just $ mapIdent name (lhs # ienv)) tyd Nothing [] undefNode),Nothing,Nothing)) 
                                               (idl # sidl)
                                return [ CDeclExt $ CDecl [ tys ] vars undefNode ]

-- scty

type CType = (CTypeSpec, [CDerivedDeclr])

sctyType  = syn scty $ do  lhs <- at lhs
                           id  <- at ch_id_Type
	   	      	   return (CTypeSpec (CTypeDef (mapIdent (value id) (lhs # ienv)) undefNode), [])


-- scexp

scexpNT =   nt_Expression .*. hNil 

intCmp2C :: IntCmp -> CBinaryOp
intCmp2C ECmp   = CEqOp 
intCmp2C NECmp  = CNeqOp
intCmp2C LCmp   = CLeOp
intCmp2C LECmp  = CLeqOp
intCmp2C GCmp   = CGrOp
intCmp2C GECmp  = CGeqOp

scexpIntCmpExp = syn scexp $ do  op <- at ch_op_IntCmpExp
                                 e1 <- at ch_e1_IntCmpExp
                                 e2 <- at ch_e2_IntCmpExp
                                 return $ CBinary (intCmp2C op) (e1 # scexp) (e2 # scexp) undefNode



intBOp2C :: IntBOp -> CBinaryOp
intBOp2C Plus   = CAddOp 
intBOp2C Minus  = CSubOp
intBOp2C Times  = CMulOp
intBOp2C Div    = CDivOp
intBOp2C Mod    = CRmdOp


scexpIntBOpExp = syn scexp $ do  op <- at ch_op_IntBOpExp
                                 e1 <- at ch_e1_IntBOpExp
                                 e2 <- at ch_e2_IntBOpExp
                                 return $ CBinary (intBOp2C op) (e1 # scexp) (e2 # scexp) undefNode

intUOp2C :: IntUOp -> CUnaryOp
intUOp2C Ng = CMinOp
intUOp2C Ps = CPlusOp


scexpIntUOpExp = syn scexp $ do  op <- at ch_op_IntUOpExp
                                 e  <- at ch_e_IntUOpExp
                                 return $ CUnary (intUOp2C op) (e # scexp) undefNode


boolBOp2C :: BoolBOp -> CBinaryOp
boolBOp2C Or   = CLorOp
boolBOp2C And  = CLndOp


scexpBoolBOpExp = syn scexp $ do  op <- at ch_op_BoolBOpExp
                                  e1 <- at ch_e1_BoolBOpExp
                                  e2 <- at ch_e2_BoolBOpExp
                                  return $ CBinary (boolBOp2C op) (e1 # scexp) (e2 # scexp) undefNode


boolUOp2C :: BoolUOp -> CUnaryOp
boolUOp2C Not   = CNegOp


scexpBoolUOpExp = syn scexp $ do  op <- at ch_op_BoolUOpExp
                                  e  <- at ch_e_BoolUOpExp
                                  return $ CUnary (boolUOp2C op) (e # scexp) undefNode


scexpIdExp      = syn scexp $ do  lhs <- at lhs
                                  i   <- at ch_id_IdExp
                                  return $ CVar (mapIdent (value i) (lhs # ienv)) undefNode

scexpIntExp     = syn scexp $ do  i <- at ch_int_IntExp
                                  return $ CConst (CIntConst  (cInteger $ (toInteger . value) i) undefNode)

scexpBoolExp    = syn scexp $ do  b <- at ch_bool_BoolExp
                                  return $ CConst (CIntConst  (cInteger $ (if value b then 1 else 0)) undefNode)

scexpParExp     = syn scexp $ do  e <- at ch_e_ParExp
                                  return $ e # scexp




-- scstmt

scstmtNT = nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. hNil

scstmtAssigStmt = syn scstmt $ do lhs  <- at lhs 
                                  id   <- at ch_id_AssigStmt
                                  exp  <- at ch_exp_AssigStmt
                                  let cid = CVar (mapIdent (value id) (lhs # ienv)) undefNode
                                  return $ CExpr (Just $ CAssign CAssignOp cid (exp # scexp) undefNode) undefNode

combCIf (Just (CIf c s me n)) els = Just $ CIf c s (combCIf me els) n
combCIf Nothing               els = els 

scstmtIfStmt  = syn scstmt $ do  if_   <- at ch_if_IfStmt
                                 elsif <- at ch_elsif_IfStmt
                                 els   <- at ch_else_IfStmt
                                 return $ case (if_ # scstmt) of 
                                           CIf c s _ n ->  CIf c s (combCIf (elsif # scstmt) (els # scstmt)) n

scstmtCondStmt = syn scstmt $ do exp  <- at ch_exp_CondStmt
                                 ss   <- at ch_ss_CondStmt
                                 return $ CIf (exp # scexp) (ss # scstmt) Nothing undefNode


-- have type (Maybe CStatement)
scstmtCondStmtL_Cons = syn scstmt $ do h <- at ch_hd_CondStmtL_Cons
                                       t <- at ch_tl_CondStmtL_Cons
                                       return $  case h # scstmt of
                                                   CIf c s _ n -> Just $ CIf c s (t # scstmt) n  

scstmtCondStmtL_Nil  = syn scstmt $ do return $  Nothing


scstmtMaybeElseStmt_Just    = syn scstmt $ do j <- at ch_just_MaybeElseStmt_Just
                                              return $  Just (j # scstmt)

scstmtMaybeElseStmt_Nothing = syn scstmt $ do return $  Nothing
--


scstmtWhileStmt = syn scstmt $ do  exp  <- at ch_exp_WhileStmt
                                   ss   <- at ch_ss_WhileStmt
                                   return $ CWhile (exp # scexp) (ss # scstmt) False undefNode



scstmtSeqStmt   = syn scstmt $ do  s1  <- at ch_s1_SeqStmt
                                   s2  <- at ch_s2_SeqStmt 
                                   return $ compStmt (s1 # scstmt) (s2 # scstmt)

scstmtEmptyStmt = syn scstmt $ do  return $  CExpr Nothing undefNode



---- Aspects

pMap :: a -> SymbolInfo String a
pMap _ = undefined


aspModule                 r = (ienvModule' r) `ext` ipreModule `ext` scgenModule `ext` (T3.aspModule (pMap r))
aspDecls                  r = ipreRule `ext` scdeclRule `ext` (T3.aspDecls (pMap r))
aspDeclL_Cons         	  r = ipreRule `ext` scdeclRule `ext` (T3.aspDeclL_Cons (pMap r))
aspDeclL_Nil         	  r = ipreRule `ext` scdeclRule `ext` (T3.aspDeclL_Nil (pMap r))
aspCstDecl                r = (senvCstDecl' r) `ext` ipreRule `ext` scdeclCstDecl `ext` (T3.aspCstDecl (pMap r))
aspTypDecl                r = (senvTypDecl' r) `ext` ipreRule `ext` scdeclTypDecl `ext` (T3.aspTypDecl (pMap r))
aspVarDecl                r = (senvVarDecl' r) `ext` ipreRule `ext` scdeclVarDecl `ext` (T3.aspVarDecl (pMap r))

aspType                   r = ipreRule `ext` sctyType `ext` (T3.aspType (pMap r))

aspAssigStmt              r = ipreRule `ext` scstmtAssigStmt `ext` (T3.aspAssigStmt (pMap r))
aspIfStmt                 r = ipreRule `ext` scstmtIfStmt `ext` (T3.aspIfStmt (pMap r))
aspWhileStmt              r = ipreRule `ext` scstmtWhileStmt `ext` (T3.aspWhileStmt (pMap r))
aspSeqStmt                r = ipreRule `ext` scstmtSeqStmt `ext` (T3.aspSeqStmt (pMap r))

aspEmptyStmt              r = ipreRule `ext` scstmtEmptyStmt `ext` (T3.aspEmptyStmt (pMap r))
 
aspCondStmtL_Cons         r = ipreRule `ext` scstmtCondStmtL_Cons `ext` (T3.aspCondStmtL_Cons (pMap r))
aspCondStmtL_Nil          r = ipreRule `ext` scstmtCondStmtL_Nil `ext` (T3.aspCondStmtL_Nil (pMap r))
aspCondStmt               r = ipreRule `ext` scstmtCondStmt `ext` (T3.aspCondStmt (pMap r))

aspMaybeElseStmt_Just     r = ipreRule `ext` scstmtMaybeElseStmt_Just `ext` (T3.aspMaybeElseStmt_Just (pMap r))
aspMaybeElseStmt_Nothing  r = ipreRule `ext` scstmtMaybeElseStmt_Nothing `ext` (T3.aspMaybeElseStmt_Nothing (pMap r))


aspIntCmpExp              r = ipreRule `ext` scexpIntCmpExp `ext` (T3.aspIntCmpExp (pMap r))
aspIntBOpExp              r = ipreRule `ext` scexpIntBOpExp `ext` (T3.aspIntBOpExp (pMap r))
aspIntUOpExp              r = ipreRule `ext` scexpIntUOpExp `ext` (T3.aspIntUOpExp (pMap r))

aspBoolBOpExp             r = ipreRule `ext` scexpBoolBOpExp `ext` (T3.aspBoolBOpExp (pMap r))
aspBoolUOpExp             r = ipreRule `ext` scexpBoolUOpExp `ext` (T3.aspBoolUOpExp (pMap r))

aspIdExp                  r = ipreRule `ext` scexpIdExp `ext` (T3.aspIdExp (pMap r))

aspIntExp                 r = ipreRule `ext` scexpIntExp `ext` (T3.aspIntExp (pMap r))
aspBoolExp                r = ipreRule `ext` scexpBoolExp `ext` (T3.aspBoolExp (pMap r))
aspParExp                 r = ipreRule `ext` scexpParExp `ext` (T3.aspParExp (pMap r))   


aspIdentL_Cons            r = (T3.aspIdentL_Cons (pMap r))
aspIdentL_Nil             r = (T3.aspIdentL_Nil (pMap r))



---- Semantic Functions


l1t5 = 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 ())