{-# LANGUAGE QuasiQuotes #-}
module Language.Java.Paragon.Compile where

import Language.Java.Paragon.Syntax
import Language.Java.Paragon.QuasiQuoter
import Language.Java.Paragon.TypeCheck.TcEnv
import Data.Generics.Uniplate.Data
import Control.Applicative
import Language.Java.Paragon.TypeCheck.Monad
import qualified Data.Map as Map 

-- shouldn't we add 'final' modifier to the actor fields?
-- what about other declarations using  primtype of policy and actor? not in method-body, not in class

-- should be called for one class/interface only
compileTransform :: CompilationUnit -> CompilationUnit
compileTransform cu = foldl (.) id [transformBi removePolicyDecls   
                                    , transformBi removeParagonModifiers
                                    , transformBi removePolicyDecls
                                    , transformBi removeLocalPolicyDecls
                                    , transformBi removePolicyExpressions
                                    , transformBi removeParagonTypeParams
                                    , transformBi removeParagonNWTypeArguments
                                    , transformBi removeParagonTypeArguments
                                    , transformBi translateTypemethodModifier
                                    , transformBi translateFieldActorDecl 
                                    , transformBi translateLocalActorDecl
                                    , transformBi translateLockDecl 
                                    , transformBi translateLockExp
                                    , transformBi translateLockStmt
                                    , transformBi translateLockBlockStmt
                                    , transformBi translateLocalLockDecl
                            ] cu
---             
translateTypemethodModifier :: Modifier -> Modifier
translateTypemethodModifier Typemethod = Static   
translateTypemethodModifier x = x

isParagonModifier :: Modifier -> Bool
isParagonModifier m = case m of
  Reflexive -> True
  Transitive -> True
  Commutative -> True
  Reads _ -> True
  Writes _   -> True
  Opens _   -> True
  Closes _ -> True
  Expects _ -> True
  _ -> False
---
removeParagonModifiers :: [Modifier] -> [Modifier]
removeParagonModifiers mods = filter (not.isParagonModifier)  mods 
---
removePolicyDecls :: [MemberDecl] -> [MemberDecl]  
removePolicyDecls membs = [m | m <- membs,
                           not $ case m of
                             PolicyDecl _ _ _ -> True
                             FieldDecl _ (PrimType PolicyT) _ -> True  
                             _ -> False
                          ]
 
---                           
removeLocalPolicyDecls ::  [BlockStmt] -> [BlockStmt] 
removeLocalPolicyDecls bstms 
  = [ b | b <- bstms,
      not $ case b of
        LocalPolicy _ _ _ -> True
        LocalVars _ (PrimType PolicyT) _  -> True
        _ -> False ]
        
--- 
removePolicyExpressions :: [Exp] -> [Exp]
removePolicyExpressions es = [ e | e <- es,
                               not $ case e of
                                 PolicyExp  _ -> True
                                 _ -> False
                             ]
---
translateFieldActorDecl ::  MemberDecl ->  MemberDecl
translateFieldActorDecl (FieldDecl mods [typeQQ|actor|]  varDecls) 
  = FieldDecl mods [typeQQ|Actor|] (translateVarDecl<$>varDecls)
translateFieldActorDecl x = x
---
translateLocalActorDecl :: BlockStmt -> BlockStmt   
translateLocalActorDecl  (LocalVars mods [typeQQ|actor|] varDecls ) 
  = LocalVars mods [typeQQ|Actor|] (translateVarDecl<$>varDecls)
translateLocalActorDecl x = x

translateVarDecl :: VarDecl -> VarDecl
translateVarDecl (VarDecl i Nothing) 
  = VarDecl i ( Just $ InitExp [expQQ|ActorFactory.generate()|] )
translateVarDecl x = x
 
---
translateLockDecl :: MemberDecl ->  MemberDecl
translateLockDecl (LockDecl mods iden maybeIdents  maybeLockprops) 
  = (FieldDecl mods [typeQQ|Lock|]  [ VarDecl (VarId iden) (Just$ InitExp [expQQ|new Lock()|])])  -- Lock iden=new Lock();
    -- I chose a new class named Lock to represent the lock type, because the contain/elem has special meaning
translateLockDecl x = x  
---
translateLockExp :: Exp -> Exp 
translateLockExp (LockExp (Lock (Name idnts) paramNames)) 
  = (MethodInv (MethodCall (Name (idnts++[Ident "check"])) (ExpName . aNameToName <$>paramNames) )) 
    -- ex:l.check(a,b,c)
translateLockExp x = x

aNameToName :: ActorName -> Name
aNameToName (ActorName n) = n
aNameToName (ActorTypeVar i) = Name [i]

---    
translateLockStmt :: Stmt -> Stmt
translateLockStmt (Open (Lock (Name idnts) paramNames)) 
  = ExpStmt (MethodInv (MethodCall (Name (idnts++ [Ident "allow"])) (ExpName . aNameToName <$>paramNames)))
     -- l.allow(a,b,c)
     -- what about empty open? ex:  open l;
translateLockStmt (Close (Lock (Name idnts) paramNames))
  =  ExpStmt (MethodInv (MethodCall (Name (idnts++ [Ident "disAllow"])) (ExpName . aNameToName <$>paramNames)))
     -- l.disAllow(a,b,c)
     -- what about empty close? ex:  close l;
translateLockStmt x = x     
---
-- Should be called before translate lock Stmts      
translateLockBlockStmt :: Stmt -> Stmt
translateLockBlockStmt (OpenBlock l b@(Block bstmts)) 
  = IfThenElse (LockExp l) 
     (StmtBlock b) 
     (StmtBlock (Block( [ BlockStmt (Open l)]
                        ++ bstmts
                        ++ [ BlockStmt (Close l)])))
translateLockBlockStmt x = x
    -- if (L) { b} else {open l; b ; close l}
--translateLockStmt (CloseBlock l b) = undefined not implemented yet
---  
translateLocalLockDecl :: BlockStmt -> BlockStmt
translateLocalLockDecl (LocalLock mods iden maybeIdents  maybeLockprops) 
  = (LocalVars mods [typeQQ|Lock|]  [ VarDecl (VarId iden) (Just$InitExp [expQQ|new Lock()|])])  -- Lock iden=new Lock();
translateLocalLockDecl x = x   
-----
removeParagonTypeParams :: [TypeParam] -> [TypeParam]
removeParagonTypeParams tps = [tp | tp@(TypeParam _ _)<-tps]

removeParagonNWTypeArguments :: [NonWildTypeArgument] -> [NonWildTypeArgument]
removeParagonNWTypeArguments tas = [ ta | ta @ ActualType {} <- tas ]

removeParagonTypeArguments :: [TypeArgument] -> [TypeArgument]
removeParagonTypeArguments [] = []
removeParagonTypeArguments (a@(ActualArg (ActualType {})) : as) = a : removeParagonTypeArguments as
removeParagonTypeArguments (ActualArg _ : as) = removeParagonTypeArguments as
removeParagonTypeArguments (a:as) = a : removeParagonTypeArguments as