{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction 
 , GADTs #-}

module Expr where

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

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

import Data.Maybe

import UU.Pretty

import Control.Monad 

data AGItf = AGItf { expr :: T_Expr}
          deriving Show

data T_Expr  =  Cst {cv  :: Int}
             |  Var {vnm :: String}
             |  Mul {me1 :: T_Expr, me2 :: T_Expr}
             |  Add {ae1 :: T_Expr, ae2 :: T_Expr}
             |  Let {lnm :: String, val :: T_Expr, body :: T_Expr}
  deriving Show



-- syn att d f     = syndef att (def d f)
-- inh att nts d f = inhdef att nts (def d f)
syn = syndefM
inh = inhdefM

$(deriveAG ''AGItf)

exprNT = nt_T_Expr .*. hNil
allNT  = nt_AGItf .*. exprNT
 


$(attLabels ["spp"])

sppAGItf  = syn spp $ liftM (# spp) (at ch_expr)
sppCst    = syn spp $ liftM pp      (at ch_cv)
sppVar    = syn spp $ liftM pp      (at ch_vnm)
sppMul    = syn spp $ do  e1 <- at ch_me1 
                          e2 <- at ch_me2
                          return $ e1 # spp >|< " * " >|< e2 # spp 
sppAdd    = syn spp $ do  e1 <- at ch_ae1 
                          e2 <- at ch_ae2
                          return $ e1 # spp >|< " + " >|< e2 # spp 

sppLet    = syn spp $ do  lnm  <- at ch_lnm
                          val  <- at ch_val
                          body <- at ch_body
                          return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    


$(attLabels ["ienv","sval"])


ienvRule  = copy ienv exprNT  
ienvAGItf = inh ienv exprNT $ do return  (ch_expr .=. ([] :: [(String,Int)]) .*.  emptyRecord)
ienvCst   = ienvRule
ienvVar   = ienvRule
ienvMul   = ienvRule
ienvAdd   = ienvRule
ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm
                                 val <- at ch_val
                                 lhs <- at lhs
                                 return  $  ch_val   .=.  lhs # ienv .*.
                                            ch_body  .=.  (lnm, val # sval) : lhs # ienv .*.  
                                            emptyRecord


svalRule  f = use sval allNT f  (0::Int)  
svalAGItf = svalRule ((*)::Int->Int->Int)
svalCst   = syn sval $ liftM id (at ch_cv)
svalVar   = syn sval $ do  vnm <- at ch_vnm 
                           lhs <- at lhs
                           return $ fromJust (lookup vnm (lhs # ienv)) 
svalMul   = svalRule ((*)::Int->Int->Int)
svalAdd   = svalRule ((+)::Int->Int->Int)
svalLet   = syn sval $ liftM (# sval) (at ch_body)


aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf
aspCst   = sppCst   `ext` ienvCst   `ext` svalCst  
aspVar   = sppVar   `ext` ienvVar   `ext` svalVar  
aspMul   = sppMul   `ext` ienvMul   `ext` svalMul  
aspAdd   = sppAdd   `ext` ienvAdd   `ext` svalAdd  
aspLet   = sppLet   `ext` ienvLet   `ext` svalLet

{-
semAGItf  e  = knit aspAGItf (ch_expr .=. e .*. emptyRecord)

semCst e     = knit aspCst  (ch_cv .=. (\(Record HNil) -> e) .*. emptyRecord)

semVar e     = knit aspVar  (ch_vnm .=. (\(Record HNil) -> e) .*. emptyRecord)

semMul e1 e2 = knit aspMul  (ch_me1 .=. e1 .*. ch_me2 .=. e2 .*. emptyRecord)

semAdd e1 e2 = knit aspAdd  (ch_ae1 .=. e1 .*. ch_ae2 .=. e2 .*. emptyRecord)

semLet l e1 e2 = knit aspLet  (ch_lnm .=. (\(Record HNil) -> l) .*. ch_val .=. e1 .*. ch_body .=. e2 .*. emptyRecord)
-}

semAGItf  r  = knit aspAGItf r 
semCst r     = knit aspCst  r
semVar r     = knit aspVar  r
semMul r     = knit aspMul  r
semAdd r     = knit aspAdd  r
semLet      = knit aspLet  

-- modifications
-- syn att d f     = syndef att (def d f)
-- inh att nts d f = inhdef att nts (def d f)
-- synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v)
-- synM att v f = synmod att (def v f)
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)

{-
sppSq = synM spp $ do me1 <- at ch_me1 
                      return $ "square " >|< (me1 # spp)   

semSq r = knit (sppSq `ext` aspMul)  (ch_me2 .=. (r # ch_me1) .*. r)
-}

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




-- identity stuff
$(chLabel "pe" ''T_Expr)
{-
synId att     = syn att $ liftM (# att) (at ch_id)
inhId att nts = inh att nts $ do lhs <- at lhs
                                 return  $  ch_id   .=.  (lhs # att) .*. emptyRecord

attsId    = (synId spp) `ext`(inhId ienv exprNT) `ext`(synId sval)
-}

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) >|< "]" 
{-
ienvSubst = inhM ienv exprNT $ do lnm <- at ch_lnm
                                  val <- at ch_val
                                  lhs <- at lhs
                                  return  $  ch_val   .=.  (lhs # ienv) .*.
                                             ch_body  .=.  ((lnm, val # sval) : (lhs # ienv)) .*.  
                                             emptyRecord
-}
semSubst r = knit (sppSubst `ext` {-ienvSubst `ext`-} aspLet) r