paragon-0.1.6: src/Language/Java/Paragon/Compile.hs
{-# 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