+%************************************************************************
+%* *
+\subsection{Class Lifting}
+%* *
+%************************************************************************
+
+This is a very simple class lifter. It works by carrying inwards a
+list of bound variables (things that might need to be passed to a
+lifted inner class).
+ * Any variable references is check with this list, and if it is
+ bound, then it is not top level, external reference.
+ * This means that for the purposes of lifting, it might be free
+ inside a lifted inner class.
+ * We remember these "free inside the inner class" values, and
+ use this list (which is passed, via the monad, outwards)
+ when lifting.
+
+\begin{code}
+type Bound = [Name]
+type Frees = [Name]
+
+combine :: [Name] -> [Name] -> [Name]
+combine [] names = names
+combine names [] = names
+combine (name:names) (name':names')
+ | name < name' = name : combine names (name':names')
+ | name > name' = name' : combine (name:names) names'
+ | name == name = name : combine names names'
+ | otherwise = error "names are not a total order"
+
+both :: [Name] -> [Name] -> [Name]
+both [] names = []
+both names [] = []
+both (name:names) (name':names')
+ | name < name' = both names (name':names')
+ | name > name' = both (name:names) names'
+ | name == name = name : both names names'
+ | otherwise = error "names are not a total order"
+
+combineEnv :: Env -> [Name] -> Env
+combineEnv (Env bound env) new = Env (bound `combine` new) env
+
+addTypeMapping :: Name -> Name -> [Name] -> Env -> Env
+addTypeMapping origName newName frees (Env bound env)
+ = Env bound ((origName,(newName,frees)) : env)
+
+data Env = Env Bound [(Name,(Name,[Name]))]
+
+newtype LifterM a =
+ LifterM { unLifterM ::
+ Name ->
+ Int -> ( a -- *
+ , Frees -- frees
+ , [Decl] -- lifted classes
+ , Int -- The uniqs
+ )
+ }
+
+instance Monad LifterM where
+ return a = LifterM (\ n s -> (a,[],[],s))
+ (LifterM m) >>= fn = LifterM (\ n s ->
+ case m n s of
+ (a,frees,lifted,s)
+ -> case unLifterM (fn a) n s of
+ (a,frees2,lifted2,s) -> ( a
+ , combine frees frees2
+ , lifted ++ lifted2
+ , s)
+ )
+
+access :: Env -> Name -> LifterM ()
+access env@(Env bound _) name
+ | name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
+ | otherwise = return ()
+
+scopedName :: Name -> LifterM a -> LifterM a
+scopedName name (LifterM m) =
+ LifterM (\ _ s ->
+ case m name 1 of
+ (a,frees,lifted,_) -> (a,frees,lifted,s)
+ )
+
+genAnonInnerClassName :: LifterM Name
+genAnonInnerClassName = LifterM (\ n s ->
+ ( n ++ "$" ++ show s
+ , []
+ , []
+ , s + 1
+ )
+ )
+
+genInnerClassName :: Name -> LifterM Name
+genInnerClassName name = LifterM (\ n s ->
+ ( n ++ "$" ++ name
+ , []
+ , []
+ , s
+ )
+ )
+
+getFrees :: LifterM a -> LifterM (a,Frees)
+getFrees (LifterM m) = LifterM (\ n s ->
+ case m n s of
+ (a,frees,lifted,n) -> ((a,frees),frees,lifted,n)
+ )
+
+rememberClass :: Decl -> LifterM ()
+rememberClass decl = LifterM (\ n s -> ((),[],[decl],s))
+
+
+liftCompilationUnit :: CompilationUnit -> CompilationUnit
+liftCompilationUnit (Package name ds) =
+ case unLifterM (liftDecls True (Env [] []) ds) [] 1 of
+ (ds,_,ds',_) -> Package name (ds ++ ds')
+
+-- The bound vars for the current class have
+-- already be captured before calling liftDecl,
+-- because they are in scope everywhere inside the class.
+
+liftDecl :: Bool -> Env -> Decl -> LifterM Decl
+liftDecl = \ top env decl ->
+ case decl of
+ { Import n -> return (Import n)
+ ; Field mfs t n e ->
+ do { e <- liftMaybeExpr env e
+ ; return (Field mfs (liftType env t) n e)
+ }
+ ; Constructor mfs n as ss ->
+ do { let newBound = getBoundAtParameters as
+ ; (ss,_) <- liftStatements (combineEnv env newBound) ss
+ ; return (Constructor mfs n (liftParameters env as) ss)
+ }
+ ; Method mfs t n as ss ->
+ do { let newBound = getBoundAtParameters as
+ ; (ss,_) <- liftStatements (combineEnv env newBound) ss
+ ; return (Method mfs (liftType env t) n (liftParameters env as) ss)
+ }
+ ; Comment s -> return (Comment s)
+ ; Interface mfs n is ms -> error "interfaces not supported"
+ ; Class mfs n x is ms ->
+ do { let newBound = getBoundAtDecls ms
+ ; ms <- scopedName n
+ (liftDecls False (combineEnv env newBound) ms)
+ ; return (Class mfs n x is ms)
+ }
+ }
+
+liftDecls :: Bool -> Env -> [Decl] -> LifterM [Decl]
+liftDecls top env = mapM (liftDecl top env)
+
+getBoundAtDecls :: [Decl] -> Bound
+getBoundAtDecls = foldr combine [] . map getBoundAtDecl
+
+-- TODO
+getBoundAtDecl :: Decl -> Bound
+getBoundAtDecl (Field _ _ n _) = [n]
+getBoundAtDecl _ = []
+
+getBoundAtParameters :: [Parameter] -> Bound
+getBoundAtParameters = foldr combine [] . map getBoundAtParameter
+
+-- TODO
+getBoundAtParameter :: Parameter -> Bound
+getBoundAtParameter (Parameter _ _ n) = [n]
+
+liftStatement :: Env -> Statement -> LifterM (Statement,Env)
+liftStatement = \ env stmt ->
+ case stmt of
+ { Skip -> return (stmt,env)
+ ; Return e -> do { e <- liftExpr env e
+ ; return (Return e,env)
+ }
+ ; Block ss -> do { (ss,env) <- liftStatements env ss
+ ; return (Block ss,env)
+ }
+ ; ExprStatement e -> do { e <- liftExpr env e
+ ; return (ExprStatement e,env)
+ }
+ ; Declaration decl@(Field mfs t n e) ->
+ do { e <- liftMaybeExpr env e
+ ; return ( Declaration (Field mfs t n e)
+ , env `combineEnv` getBoundAtDecl decl
+ )
+ }
+ ; Declaration decl@(Class mfs n x is ms) ->
+ do { innerName <- genInnerClassName n
+ ; frees <- liftClass env innerName ms x is
+ ; return ( Declaration (Comment ["lifted " ++ n])
+ , addTypeMapping n innerName frees env
+ )
+ }
+ ; Declaration d -> error "general Decl not supported"
+ ; IfThenElse ecs s -> ifthenelse env ecs s
+ ; Switch e as d -> error "switch not supported"
+ }
+
+ifthenelse :: Env
+ -> [(Expr,Statement)]
+ -> (Maybe Statement)
+ -> LifterM (Statement,Env)
+ifthenelse env pairs may_stmt =
+ do { let (exprs,stmts) = unzip pairs
+ ; exprs <- liftExprs env exprs
+ ; (stmts,_) <- liftStatements env stmts
+ ; may_stmt <- case may_stmt of
+ Just stmt -> do { (stmt,_) <- liftStatement env stmt
+ ; return (Just stmt)
+ }
+ Nothing -> return Nothing
+ ; return (IfThenElse (zip exprs stmts) may_stmt,env)
+ }
+
+liftStatements :: Env -> [Statement] -> LifterM ([Statement],Env)
+liftStatements env [] = return ([],env)
+liftStatements env (s:ss) =
+ do { (s,env) <- liftStatement env s
+ ; (ss,env) <- liftStatements env ss
+ ; return (s:ss,env)
+ }
+
+
+liftExpr :: Env -> Expr -> LifterM Expr
+liftExpr = \ env expr ->
+ case expr of
+ { Var n -> do { access env n
+ ; return (Var n)
+ }
+ ; Literal l -> return expr
+ ; Cast t e -> do { e <- liftExpr env e
+ ; return (Cast (liftType env t) e)
+ }
+ ; Access e n -> do { e <- liftExpr env e
+ -- do not consider n as an access, because
+ -- this is a indirection via a reference
+ ; return (Access e n)
+ }
+ ; Assign l r -> do { l <- liftExpr env l
+ ; r <- liftExpr env r
+ ; return (Assign l r)
+ }
+ ; InstanceOf e t -> do { e <- liftExpr env e
+ ; return (InstanceOf e (liftType env t))
+ }
+ ; Call e n es -> do { e <- liftExpr env e
+ ; es <- mapM (liftExpr env) es
+ ; return (Call e n es)
+ }
+ ; Op e1 o e2 -> do { e1 <- liftExpr env e1
+ ; e2 <- liftExpr env e1
+ ; return (Op e1 o e2)
+ }
+ ; New n es ds -> new env n es ds
+ ; NewArray n es -> error "array not (yet) supported"
+ }
+
+liftParameter env (Parameter ms t n) = Parameter ms (liftType env t) n
+liftParameters env = map (liftParameter env)
+
+liftExprs :: Env -> [Expr] -> LifterM [Expr]
+liftExprs = mapM . liftExpr
+
+liftMaybeExpr :: Env -> (Maybe Expr) -> LifterM (Maybe Expr)
+liftMaybeExpr env Nothing = return Nothing
+liftMaybeExpr env (Just stmt) = do { stmt <- liftExpr env stmt
+ ; return (Just stmt)
+ }
+
+
+new :: Env -> Type -> [Expr] -> Maybe [Decl] -> LifterM Expr
+new env@(Env _ pairs) typ args Nothing =
+ do { args <- liftExprs env args
+ ; return (mkNew env typ args)
+ }
+new env typ [] (Just inner) =
+ -- anon. inner class
+ do { innerName <- genAnonInnerClassName
+ ; frees <- liftClass env innerName inner [] []
+ ; return (mkNew env typ [ Var name | name <- frees ])
+ }
+new env typ _ (Just inner) = error "cant handle inner class with args"
+
+liftClass :: Env -> Name -> [Decl] -> [Name] -> [Name] -> LifterM [ Name ]
+liftClass env@(Env bound _) innerName inner xs is =
+ do { let newBound = getBoundAtDecls inner
+ ; (inner,frees) <-
+ getFrees (liftDecls False (env `combineEnv` newBound) inner)
+ ; let trueFrees = both frees bound
+ ; let mirrorFrees = [ "_" ++ name ++ "_" | name <- trueFrees ]
+ ; let freeDefs = [ Field [Final] objectType n Nothing | n <- trueFrees ]
+ ; let cons = Constructor [Public] innerName
+ [ Parameter [] objectType name | name <- mirrorFrees ]
+ [ ExprStatement (Assign (Var true) (Var mirror))
+ | (true,mirror) <- zip trueFrees mirrorFrees
+ ]
+ ; let innerClass = Class [] innerName xs is (freeDefs ++ [cons] ++ inner)
+ ; rememberClass innerClass
+ ; return trueFrees
+ }
+
+liftType :: Env -> Type -> Type
+liftType (Env _ env) typ@(Type [name])
+ = case lookup name env of
+ Nothing -> typ
+ Just (nm,_) -> Type [nm]
+liftType _ typ = typ
+
+mkNew :: Env -> Type -> [Expr] -> Expr
+mkNew (Env _ env) typ@(Type [name]) exprs
+ = case lookup name env of
+ Nothing -> New typ exprs Nothing
+ Just (nm,args) | null exprs
+ -> New (Type [nm]) (map Var args) Nothing
+ _ -> error "pre-lifted constructor with arguments"
+mkNew _ typ exprs = New typ exprs Nothing
+\end{code}