{-# 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"