paragon-0.1.28: src/Language/Java/Paragon/Compile.hs
{-# LANGUAGE QuasiQuotes #-}
module Language.Java.Paragon.Compile (compileTransform) where
import Language.Java.Paragon.Syntax
import Language.Java.Paragon.Pretty
import Language.Java.Paragon.TypeCheck.Types
import Language.Java.Paragon.Interaction
import Data.Generics.Uniplate.Data
import Data.List (nub)
import Data.Maybe (fromJust)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as B
compilerModule :: String
compilerModule = libraryBase ++ ".Compile"
compileTransform :: CompilationUnit T -> CompilationUnit ()
compileTransform cu = compileTransform' $ fmap (const ()) cu -- Not making use of those T annotations yet
-- 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
compileTransform' :: CompilationUnit () -> CompilationUnit ()
compileTransform' = transformBi compileClassDecl . transformBi compileInterfaceDecl
compileInterfaceDecl :: InterfaceDecl () -> InterfaceDecl ()
compileInterfaceDecl (InterfaceDecl _ ms i tps sups ibody) =
let ms' = removeParagonMods ms -- No lockstate mods allowed here
sups' = map compileClassType sups
(tps', _tpMembers, _tpPars, _tpAsss) = splitTypeParams tps
in InterfaceDecl () ms' i tps' sups' $
compileInterfaceBody ibody
compileInterfaceBody :: InterfaceBody () -> InterfaceBody ()
compileInterfaceBody (InterfaceBody _ mds) =
InterfaceBody () $ map (compileSimpleMemberDecl [] []) mds
-- 1. Remove Paragon modifiers
-- 2. Transform Paragon type params into ordinary params
-- 3. Transform body
compileClassDecl :: ClassDecl () -> ClassDecl ()
compileClassDecl (ClassDecl _ ms i tps mSuper impls cbody) =
let ms' = removeParagonMods ms -- No lockstate mods allowed here
mSuper' = fmap compileClassType mSuper
impls' = map compileClassType impls
(tps', tpMembers, tpPars, tpAsss) = splitTypeParams tps
in ClassDecl () ms' i tps' mSuper' impls' $
compileClassBody cbody tpMembers tpPars tpAsss
compileClassDecl _ = panic (compilerModule ++ ".compileClassDecl")
$ "Enum not supported"
-- Paragon type parameters need to be replaced by runtime counterparts.
-- 1. Lock state parameters should be removed completed.
-- 2. Actor and Policy parameters need to be around at runtime. Each
-- parameter is translated into:
-- a) a field of the parameterized class
-- b) a parameter to every constructor of the class
-- c) an assignment of the parameter b) to the field a)
-- at the beginning of every constructor of the class
splitTypeParams :: [TypeParam ()] -> ([TypeParam ()],[MemberDecl ()],[FormalParam ()],[BlockStmt ()])
splitTypeParams = go ([],[],[],[]) -- error "compileTypeParams undefined"
where
go (ttps,fds,fps,as) [] = (reverse ttps, reverse fds, reverse fps, reverse as)
go (ttps,fds,fps,as) (tp:tps) =
case tp of
TypeParam{} -> go (tp:ttps,fds,fps,as) tps -- Retain
LockStateParam{} -> go ( ttps,fds,fps,as) tps -- Ignore
_ -> let (i,ty) =
case tp of
ActorParam _ iP ->
(iP, -- [typeQQ| se.chalmers.paragon.ConcreteActor |]
concreteActorType)
PolicyParam _ iP ->
(iP, -- [typeQQ| se.chalmers.paragon.Policy |]
policyType)
_ -> panic (compilerModule ++ ".splitTypeParams")
$ show tp
fd = -- [fieldDeclQQ| public final #T#ty #i; |]
FieldDecl () [Public (),Final ()] ty [VarDecl () (VarId () i) Nothing]
fp = -- [formalParamQQ| final #T#ty #i |]
FormalParam () [Final ()] ty False (VarId () i)
a = -- [blockStmtQQ| this.#i = #i; |]
BlockStmt () (ExpStmt () (Assign ()
(FieldLhs () (PrimaryFieldAccess () (This ()) i))
(EqualA ()) (ExpName () (Name () EOrLName Nothing i))))
in go (ttps,fd:fds,fp:fps,a:as) tps
compileClassBody :: ClassBody () -> [MemberDecl ()] -> [FormalParam ()] -> [BlockStmt ()] -> ClassBody ()
compileClassBody (ClassBody _ ds) _tpMembers tpPars tpAsss =
let ds' = concat $ map (compileDecl tpPars tpAsss) ds
in ClassBody () ({- map (MemberDecl ()) tpMembers ++ -} ds')
compileDecl :: [FormalParam ()] -> [BlockStmt ()] -> Decl () -> [Decl ()]
compileDecl _ _ (InitDecl _ _ _) = error "InitDecl not yet supported"
compileDecl tpPars tpAsss (MemberDecl _ md) = compileMemberDecl tpPars tpAsss md
compileMemberDecl :: [FormalParam ()] -> [BlockStmt ()] -> MemberDecl () -> [Decl ()]
compileMemberDecl tpPars tpAsss md =
case md of
LockDecl {} -> compileLockDecl md
_ -> (:[]) . MemberDecl () $ compileSimpleMemberDecl tpPars tpAsss md
compileSimpleMemberDecl :: [FormalParam ()] -> [BlockStmt ()] -> MemberDecl () -> MemberDecl ()
compileSimpleMemberDecl _tpPars tpAsss md =
case md of
-- Actors
FieldDecl _ ms t vds -> compileVarDeclGeneric (FieldDecl ()) ms t vds
MethodDecl _ ms tps rt i fps xs mb ->
-- TODO: tpPs should become actual pars (NOT tpPars)
let ms' = removeParagonMods ms
(tps', _, _tpPs, _) = splitTypeParams tps
rt' = compileReturnType rt
fps' = map compileFormalParam fps
xs' = map compileExn xs
in MethodDecl () ms' tps' rt' i fps' xs' $ compileMethodBody mb
ConstructorDecl _ ms tps i fps xs cb ->
let ms' = removeParagonMods ms
(tps', _, _tpPs, _) = splitTypeParams tps
fps' = map compileFormalParam fps
xs' = map compileExn xs
in ConstructorDecl () ms' tps' i ({- tpPars ++ -} fps') xs' $ compileConstrBody tpAsss cb
_ -> panic (compilerModule ++ ".compileSimpleMemberDecl")
$ prettyPrint md
compileConstrBody :: [BlockStmt ()] -> ConstructorBody () -> ConstructorBody ()
compileConstrBody _tpAsss (ConstructorBody _ meci bss) =
ConstructorBody () (fmap compileECI meci) ({- _tpAsss ++ -} map compileBlockStmt bss)
compileECI :: ExplConstrInv () -> ExplConstrInv ()
compileECI (ThisInvoke _ tas as) = ThisInvoke () (compileNWTypeArgs tas) (map compileExp as)
compileECI (SuperInvoke _ tas as) = SuperInvoke () (compileNWTypeArgs tas) (map compileExp as)
compileECI (PrimarySuperInvoke _ e tas as) =
PrimarySuperInvoke () (compileExp e) (compileNWTypeArgs tas) (map compileExp as)
compileFormalParam :: FormalParam () -> FormalParam ()
compileFormalParam (FormalParam _ ms t va vid) =
FormalParam () (removeParagonMods ms) (compileType t) va vid
actorVarDecl, policyVarDecl, compileVarDecl :: VarDecl () -> VarDecl ()
actorVarDecl (VarDecl _ (VarId _ i@(Ident _ rawI)) Nothing)
= -- [varDeclQQ| $$i = Actor.newConcreteActor($s$rawI) |]
vDecl i $ callStatic "Actor" "newConcreteActor"
[Lit () $ String () $ B.unpack rawI]
actorVarDecl vd = compileVarDecl vd
policyVarDecl (VarDecl _ (VarId _ i@(Ident _ rawI))
(Just (InitExp _ (PolicyExp _ (PolicyLit _ cs)))))
= vDecl i $ callStatic "Policy" "newPolicy"
(Lit () (String () $ B.unpack rawI) : map clauseToExp cs)
policyVarDecl vd = compileVarDecl vd
compileVarDecl (VarDecl _ vid mInit) = VarDecl () vid $ compileVarInit mInit
compileExn :: ExceptionSpec () -> ExceptionSpec ()
compileExn (ExceptionSpec _ _ms rt) = ExceptionSpec () [] -- no modifiers on exceptions in java!
$ compileRefType rt
compileReturnType :: ReturnType () -> ReturnType ()
compileReturnType (LockType _) = Type () $ PrimType () $ BooleanT ()
compileReturnType (Type _ t) = Type () $ compileType t
compileReturnType rett = rett
compileType :: Type () -> Type ()
compileType (RefType _ rt) = RefType () $ compileRefType rt
compileType t = t
compileRefType :: RefType () -> RefType ()
compileRefType (ArrayType _ t mps) =
ArrayType () (compileType t) $ map (const Nothing) mps -- No policy parameters!
compileRefType (ClassRefType _ ct) = ClassRefType () $ compileClassType ct
compileRefType rt = rt
compileClassType :: ClassType () -> ClassType ()
compileClassType (ClassType _ n tas) = ClassType () n $ compileTypeArgs tas
compileTypeArgs :: [TypeArgument ()] -> [TypeArgument ()]
compileTypeArgs _ = [] -- TODO: Cheating!!!
compileNWTypeArgs :: [NonWildTypeArgument ()] -> [NonWildTypeArgument ()]
compileNWTypeArgs _ = [] -- TODO: Cheating!!!
compileMethodBody :: MethodBody () -> MethodBody ()
compileMethodBody (MethodBody _ (Just bl)) = MethodBody () . Just $ compileBlock bl
compileMethodBody mb = mb
compileBlock :: Block () -> Block ()
compileBlock (Block _ bss) = Block () $ map compileBlockStmt bss
compileBlockStmt :: BlockStmt () -> BlockStmt ()
compileBlockStmt (BlockStmt _ stmt) = BlockStmt () $ compileStmt stmt
compileBlockStmt (LocalVars _ ms t vds) = compileVarDeclGeneric (LocalVars ()) ms t vds
compileBlockStmt bss = panic (compilerModule ++ ".compileBlockStmt")
$ prettyPrint bss
compileVarDeclGeneric :: ([Modifier ()] -> Type () -> [VarDecl ()] -> res)
-> [Modifier ()] -> Type () -> [VarDecl ()] -> res
compileVarDeclGeneric con ms t vds =
let (t', vds') = case t of
PrimType _ (PolicyT _) -> (policyType, map policyVarDecl vds)
PrimType _ (ActorT _) -> (concreteActorType, map actorVarDecl vds)
_ -> (compileType t, map compileVarDecl vds)
in con (removeParagonMods ms) t' vds'
compileStmt :: Stmt () -> Stmt ()
compileStmt (StmtBlock _ bl) = StmtBlock () $ compileBlock bl
compileStmt (Open _ _) = Empty ()
compileStmt (Close _ _) = Empty ()
compileStmt (OpenBlock _ _ bl) = StmtBlock () $ compileBlock bl
compileStmt (CloseBlock _ _ bl) = StmtBlock () $ compileBlock bl
compileStmt (IfThen _ e s) = IfThen () (compileExp e) (compileStmt s)
compileStmt (IfThenElse _ e th el) = IfThenElse () (compileExp e) (compileStmt th) (compileStmt el)
compileStmt (While _ e s) = While () (compileExp e) (compileStmt s)
compileStmt (BasicFor _ mIn mTest mUp s) =
let mIn' = fmap compileForInit mIn
mTest' = fmap compileExp mTest
mUp' = fmap (map compileExp) mUp
in BasicFor () mIn' mTest' mUp' $ compileStmt s
compileStmt (ExpStmt _ e) = ExpStmt () $ compileExp e
compileStmt (Return _ me) = Return () $ fmap compileExp me
compileStmt (Throw _ e) = Throw () $ compileExp e
compileStmt (Try _ bl cs mfin) = Try () (compileBlock bl) (map compileCatch cs) (fmap compileBlock mfin)
compileStmt st = fmap (const ()) st
compileForInit :: ForInit () -> ForInit ()
compileForInit (ForInitExps _ es) = ForInitExps () $ map compileExp es
compileForInit (ForLocalVars _ ms t vds) = compileVarDeclGeneric (ForLocalVars ()) ms t vds
compileCatch :: Catch () -> Catch ()
compileCatch (Catch _ fp bl) = Catch () (compileFormalParam fp) (compileBlock bl)
compileVarInit :: Maybe (VarInit ()) -> Maybe (VarInit ())
compileVarInit Nothing = Nothing
compileVarInit (Just (InitExp _ e )) = Just . InitExp () $ compileExp e
compileVarInit (Just (InitArray _ ai)) = Just . InitArray () $ compileArrayInit ai
compileArrayInit :: ArrayInit () -> ArrayInit ()
compileArrayInit _ = error "compileArrayInit: Not yet implemented"
compileExp :: Exp () -> Exp ()
compileExp = transformBi compileExp'
compileExp' :: Exp () -> Exp ()
compileExp' (PolicyExp _ pe) = compilePolicyExp pe
-- For instance creation, we need to move type
-- arguments to actual arguments -- but not right now!
compileExp' (InstanceCreation _ _tas ct args mcbody) =
InstanceCreation () [] (compileClassType ct) (map compileExp args)
(fmap (\cb -> compileClassBody cb [] [] []) mcbody)
{-
compileExp' (QualInstanceCreation e tas i args mcbody) = do
undefined -}
compileExp' (ArrayCreate _ t edims idims) =
let edims' = map (compileExp *** const Nothing) edims
idims' = map (const Nothing) idims
in ArrayCreate () (compileType t) edims' idims'
compileExp' (MethodInv _ mi) = MethodInv () $ compileMethodInv mi
compileExp' (Cast _ t e) = Cast () (compileType t) (compileExp e)
-- Lock names must be handled in a special way - but not right now!
-- compileExp' (ExpName _ n) = undefined
compileExp' (LockExp _ l) = lockExpToExp l
-- Certain operators have special effects on paragon types
-- - but not right now!
--compileExp' (BinOp _ e1 op e2) = compileBinOp op e1 e2
compileExp' e = fmap (const ()) e
compileMethodInv :: MethodInvocation () -> MethodInvocation ()
compileMethodInv mi = case mi of
MethodCallOrLockQuery _ n as -> MethodCallOrLockQuery () n $ map compileExp as
PrimaryMethodCall _ e _tas i as ->
PrimaryMethodCall () (compileExp e) [] i $ map compileExp as
TypeMethodCall _ n _tas i as ->
TypeMethodCall () n [] i $ map compileExp as
_ -> panic (compilerModule ++ ".compileMethodInv")
$ prettyPrint mi
-- Compiling binary operators. The interesting cases are
-- the ones where the operands are policies.
--compileBinOp :: Op () -> Exp () -> Exp () -> Exp ()
--compileBinOp = undefined
lockExpToExp :: Lock () -> Exp ()
lockExpToExp (Lock _ n _ans) = -- [expQQ| #N#n.isOpen() |]
MethodInv () (MethodCallOrLockQuery ()
(Name () MName (Just n) (Ident () $ B.pack "isOpen")) [])
lockExpToExp (LockVar _ i) =
MethodInv () (MethodCallOrLockQuery ()
(Name () MName (Just $ mkSimpleName EName i) (Ident () $ B.pack "isOpen")) [])
--------------------------------------------
-- Compiling lock and policy declarations
-- Policies
compilePolicyExp :: PolicyExp () -> Exp ()
compilePolicyExp (PolicyLit _ cs) = callStatic "Policy" "newPolicy"
(Lit () (String () "") : map clauseToExp cs)
compilePolicyExp (PolicyTypeVar _ i) = ExpName () (mkSimpleName EName i)
-- PolicyOf may only appear in modifiers, which will have been removed.
compilePolicyExp pe =
panic (compilerModule ++ ".compilePolicyExp")
$ prettyPrint pe
-- Clauses and components
clauseToExp :: Clause () -> Exp ()
clauseToExp (Clause _ h body) =
let vs = nub [ a | Var _ a <- universeBi h ++ universeBi body ] `zip` [0..] -- Substs
exps = actorToExp vs h : map (atomToExp vs) body
in callStatic "Policy" "newPClause" exps
headToExp, atomToExp :: [(Ident (), Int)] -> Atom () -> Exp ()
headToExp vs (Atom _ _ acts) =
callStatic "ActorList" "newActorList" (map (actorToExp vs) acts)
atomToExp vs (Atom _ n acts) =
callStatic "Atom" "newAtom" (ExpName () n: map (actorToExp vs) acts)
actorToExp :: [(Ident (), Int)] -> Actor () -> Exp ()
actorToExp _vs (Actor _ (ActorName _ n)) = ExpName () n
actorToExp _vs (Actor _ (ActorTypeVar _ tv)) = ExpName () (mkSimpleName EName tv)
actorToExp vs (Var _ i) =
let k = fromIntegral $ fromJust (lookup i vs)
in callStatic "Actor" "newActorVariable" [Lit () $ Int () k]
-- Locks
-- Compile a lock declaration into a (static) Lock declaration
-- plus (static) initialization of its lock properties.
-- Precondition: md is a LockDecl
compileLockDecl :: MemberDecl () -> [Decl ()]
compileLockDecl md =
case md of
LockDecl _ ms i@(Ident _ rawI) pars mLProps ->
let -- Properties defined in modifiers
lmExps = map (lockModToExp i) $ filter isLockMod ms
-- Properties defined explicitly
lpExps = maybe []
(map (lockPropToExp i) . (\(LockProperties _ cs) -> cs))
mLProps
lockE = callStatic "Lock" "newLock"
[Lit () $ String () $ B.unpack rawI, Lit () $ Int () (fromIntegral $ length pars)]
lockD = FieldDecl () (Static ():Final ():removeParagonMods ms)
lockType
-- [typeQQ| se.chalmers.paragon.Lock |]
[vDecl i lockE]
in MemberDecl () lockD :
lockExpsToInit i (lmExps ++ lpExps) -- map (uncurry $ lockRhsToMd i)
-- ((lmExps ++ lpExps) `zip` [0..])
_ -> fail $ "Internal error: compileLockDecl: " ++ show md
-- Initialization code for lock properties
lockExpsToInit :: Ident () -> [Exp ()] -> [Decl ()]
lockExpsToInit _ [] = []
lockExpsToInit _i es = [InitDecl () True . Block () $
map (BlockStmt () . ExpStmt ()) es]
lockPropToExp :: Ident () -> LClause () -> Exp ()
lockPropToExp _i@(Ident _ rawI) (LClause _ h body) =
let vs = nub [ a | Var _ a <- universeBi (h:body) ] `zip` [0..] -- Substs
exps = headToExp vs h : map (atomToExp vs) body
in call [B.unpack rawI,"addClause"] exps
lockPropToExp i _ = panic (compilerModule ++ ".lockPropToExp")
$ prettyPrint i
lockModToExp :: Ident () -> Modifier () -> Exp ()
lockModToExp (Ident _ rawI) m =
let mname = prettyPrint m
in call [B.unpack rawI,mname] []
lockModToExp i _ = panic (compilerModule ++ ".lockModToExp")
$ prettyPrint i
isLockMod :: Modifier () -> Bool
isLockMod m = case m of
Reflexive () -> True
Transitive () -> True
Symmetric () -> True
_ -> False
isParagonMod :: Modifier () -> Bool
isParagonMod m = case m of
Typemethod _ -> True
Readonly _ -> True
Reflexive _ -> True
Transitive _ -> True
Symmetric _ -> True
Reads _ _ -> True
Writes _ _ -> True
Opens _ _ -> True
Closes _ _ -> True
Expects _ _ -> True
_ -> False
removeParagonMods :: [Modifier ()] -> [Modifier ()]
removeParagonMods = filter (not . isParagonMod)
callStatic :: String -> String -> [Exp ()] -> Exp ()
callStatic typ met args =
MethodInv () $ MethodCallOrLockQuery ()
(Name () MName (Just $ mkPkgTypeName typ) (Ident () $ B.pack met)) args
call :: [String] -> [Exp ()] -> Exp ()
call strs args =
MethodInv () $ MethodCallOrLockQuery () (mkName const MName EName $ map (Ident () . B.pack) strs) args
vDecl :: Ident () -> Exp () -> VarDecl ()
vDecl i initz = VarDecl () (VarId () i) (Just $ InitExp () initz)
pkgPrefix :: Name ()
pkgPrefix = mkUniformName const PName $ map (Ident () . B.pack) ["se","chalmers","paragon"]
mkPkgTypeName :: String -> Name ()
mkPkgTypeName str = Name () TName (Just pkgPrefix) (Ident () $ B.pack str)
mkPkgType :: String -> Type ()
mkPkgType str = RefType () $ ClassRefType () $ ClassType () (mkPkgTypeName str) []
concreteActorType, policyType, lockType :: Type ()
concreteActorType = mkPkgType "ConcreteActor"
policyType = mkPkgType "Policy"
lockType = mkPkgType "Lock"