From: andy Date: Wed, 7 Jun 2000 06:10:53 +0000 (+0000) Subject: [project @ 2000-06-07 06:10:53 by andy] X-Git-Tag: Approximately_9120_patches~4316 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=483f06bdb54f2c5f8eb80ebb493cf535accfc482;p=ghc-hetmet.git [project @ 2000-06-07 06:10:53 by andy] Adding types to the names inside the GOO. All needed for a langauge with unboxed types ... --- diff --git a/ghc/compiler/javaGen/Java.lhs b/ghc/compiler/javaGen/Java.lhs index 578be9a..ede6ac2 100644 --- a/ghc/compiler/javaGen/Java.lhs +++ b/ghc/compiler/javaGen/Java.lhs @@ -22,21 +22,21 @@ module Java where \begin{code} data CompilationUnit - = Package Name [Decl] + = Package PackageName [Decl] deriving (Show) data Decl = Import PackageName - | Field [Modifier] Type Name (Maybe Expr) - | Constructor [Modifier] Name [Parameter] [Statement] - | Method [Modifier] Type Name [Parameter] [Exception] [Statement] + | Field [Modifier] Name (Maybe Expr) + | Constructor [Modifier] TypeName [Parameter] [Statement] + | Method [Modifier] Name [Parameter] [Exception] [Statement] | Comment [String] - | Interface [Modifier] Name [TypeName] [Decl] - | Class [Modifier] Name [TypeName] [TypeName] [Decl] + | Interface [Modifier] TypeName [TypeName] [Decl] + | Class [Modifier] TypeName [TypeName] [TypeName] [Decl] deriving (Show) data Parameter - = Parameter [Modifier] Type Name + = Parameter [Modifier] Name deriving (Show) data Statement @@ -55,10 +55,10 @@ data Statement deriving (Show) data Expr - = Var Name Type - | Literal Lit Type + = Var Name + | Literal Lit | Cast Type Expr - | Access Expr Name -- perhaps: Access Expr Var? + | Access Expr Name | Assign Expr Expr | InstanceOf Expr Type | Call Expr Name [Expr] @@ -90,6 +90,7 @@ data PrimType | PrimFloat | PrimDouble | PrimByte + | PrimVoid deriving (Show) type PackageName = String -- A package name @@ -101,10 +102,24 @@ type TypeName = String -- a fully qualified type name -- like "java.lang.Object". -- has type "Type " -type Name = String -- A class name or method etc, +data Name = Name String Type + deriving Show -- A class name or method etc, -- at defintion time, -- this generally not a qualified name. + -- The type is shape of the box require + -- to store an access to this thing. + -- So variables might be Int or Object. + + -- ** method calls store the returned + -- ** type, not a complete. + -- + -- Thinking: + -- ... foo1.foo2(...).foo3 ... + -- here you want to know the *result* + -- after callling foo1, then foo2, + -- then foo3. + data Lit = IntLit Integer -- unboxed @@ -116,13 +131,16 @@ addModifier :: Modifier -> Decl -> Decl addModifier = \m -> \d -> case d of { Import n -> Import n - ; Field ms t n e -> Field (m:ms) t n e + ; Field ms n e -> Field (m:ms) n e ; Constructor ms n as ss -> Constructor (m:ms) n as ss - ; Method ms t n as ts ss -> Method (m:ms) t n as ts ss + ; Method ms n as ts ss -> Method (m:ms) n as ts ss ; Comment ss -> Comment ss ; Interface ms n xs ds -> Interface (m:ms) n xs ds ; Class ms n xs is ds -> Class (m:ms) n xs is ds } + +changeNameType :: Type -> Name -> Name +changeNameType ty (Name n _) = Name n ty areSimple :: [Expr] -> Bool areSimple = \es -> all isSimple es diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index a44b529..34cf42b 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -68,7 +68,7 @@ import Outputable javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit javaGen mod import_mods tycons binds - = liftCompilationUnit package + = id {-liftCompilationUnit-} package where decls = [Import "haskell.runtime.*"] ++ [Import (moduleString mod) | mod <- import_mods] ++ @@ -97,7 +97,7 @@ javaTyCon tycon = tycon_jclass : concat (map constr_class constrs) where constrs = tyConDataCons tycon - tycon_jclass_jname = addCons (javaName tycon) + tycon_jclass_jname = javaGlobTypeName tycon ++ "zdc" tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] [] constr_class data_con @@ -109,45 +109,43 @@ javaTyCon tycon constr_jtype = javaConstrWkrType data_con field_names = constrToFields data_con - field_decls = [ Field [Public] t f Nothing - | (f,t) <- field_names + field_decls = [ Field [Public] n Nothing + | n <- field_names ] cons_meth = mkCons (shortName constr_jname) field_names - debug_meth = Method [Public] stringT - "toString" + debug_meth = Method [Public] (Name "toString" stringType) [] [] - ( [ Declaration (Field [] stringT "__txt" Nothing) ] + ( [ Declaration (Field [] txt Nothing) ] ++ [ ExprStatement - (Assign txt (Literal - (StringLit + (Assign (Var txt) + (mkStr ("( " ++ getOccString data_con ++ " ") - ) - stringT - ) + ) ) ] ++ [ ExprStatement - (Assign txt - (Op txt "+" - (Op (Var f t) "+" litSp) + (Assign (Var txt) + (Op (Var txt) + "+" + (Op (Var n) "+" litSp) ) ) - | (f,t) <- field_names + | n <- field_names ] - ++ [ Return (Op txt "+" - (Literal (StringLit ")") stringT) + ++ [ Return (Op (Var txt) + "+" + (mkStr ")") ) ] ) - stringT = Type "java.lang.String" - litSp = Literal (StringLit " ") stringT - txt = Var "__txt" stringT + litSp = mkStr " " + txt = Name "__txt" stringType mkNew :: Type -> [Expr] -> Expr @@ -155,22 +153,23 @@ mkNew t@(PrimType primType) [] = error "new primitive???" mkNew t@(Type _) es = New t es Nothing mkNew _ _ = error "new with strange arguments" +constrToFields :: DataCon -> [Name] +constrToFields cons = + [ fieldName i t + | (i,t) <- zip [1..] (map javaTauType (dataConRepArgTys cons)) + ] -addCons :: Name -> Name -addCons name = name ++ "zdc" - -constrToFields :: DataCon -> [(Name,Type)] -constrToFields cons = zip (map fieldName [1..]) - (map javaTauType (dataConRepArgTys cons)) - -mkCons :: Name -> [(Name,Type)] -> Decl +mkCons :: TypeName -> [Name] -> Decl mkCons name args = Constructor [Public] name - [ Parameter [] t n | (n,t) <- args ] + [ Parameter [] n | n <- args ] [ ExprStatement (Assign (Access this n) - (Var n t) + (Var n) ) - | (n,t) <- args ] + | n <- args ] + +mkStr :: String -> Expr +mkStr str = Literal (StringLit str) \end{code} %************************************************************************ @@ -189,9 +188,10 @@ java_top_bind :: Id -> CoreExpr -> Decl -- public Object ENTER() { ...translation of rhs... } -- } java_top_bind bndr rhs - = Class [Public] (shortName (javaName bndr)) [] [codeName] [enter_meth] + = Class [Public] (shortName (javaGlobTypeName bndr)) + [] [codeName] [enter_meth] where - enter_meth = Method [Public] objectType enterName [vmArg] [excName] + enter_meth = Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN rhs) \end{code} @@ -205,11 +205,11 @@ java_top_bind bndr rhs \begin{code} javaVar :: Id -> Expr javaVar v | isGlobalName (idName v) = mkNew (javaGlobType v) [] - | otherwise = Var (javaName v) (javaType v) + | otherwise = Var (javaName v) javaLit :: Literal.Literal -> Expr -javaLit (MachInt i) = Literal (IntLit (fromInteger i)) (PrimType PrimInt) -javaLit (MachChar c) = Literal (CharLit c) (PrimType PrimChar) +javaLit (MachInt i) = Literal (IntLit (fromInteger i)) +javaLit (MachChar c) = Literal (CharLit c) javaLit other = pprPanic "javaLit" (ppr other) javaExpr :: (Expr -> Expr) -> CoreExpr -> [Statement] @@ -237,7 +237,7 @@ javaCase :: (Expr -> Expr) -> CoreExpr -> Id -> [CoreAlt] -> [Statement] -- } else return null javaCase r e x alts - = [var [Final] objectType (javaName x) (vmWHNF (javaArg e)), + = [var [Final] (javaName x) (vmWHNF (javaArg e)), IfThenElse (map mk_alt alts) Nothing] where mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr r rhs)) @@ -247,14 +247,17 @@ javaCase r e x alts mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt) - eqLit (MachInt n) = Op (Literal (IntLit n) (PrimType PrimInt)) + eqLit (MachInt n) = Op (Literal (IntLit n)) "==" - (Var (javaName x) (PrimType PrimInt)) + (Var (javaName x)) eqLit other = pprPanic "eqLit" (ppr other) - bind_args d bs = [var [Final] t (javaName b) - (Access (Cast (javaConstrWkrType d) (javaVar x)) f) - | (b, (f,t)) <- filter isId bs `zip` (constrToFields d) + bind_args d bs = [var [Final] (javaName b) + (Access (Cast (javaConstrWkrType d) (javaVar x) + ) f + ) + | (b,f) <- filter isId bs + `zip` (constrToFields d) , not (isDeadBinder b) ] @@ -264,7 +267,9 @@ javaBind (NonRec x rhs) ==> final Object x = new Thunk( new Code() { ...code for rhs_x... } ) -} - = [var [Final] objectType (javaName x) (newThunk (newCode (javaExpr vmRETURN rhs)))] + = [var [Final] (javaLocName x objectType) + (newThunk (newCode (javaExpr vmRETURN rhs))) + ] javaBind (Rec prs) {- rec { x = ...rhs_x...; y = ...rhs_y... } @@ -288,33 +293,35 @@ javaBind (Rec prs) = (map mk_class prs) ++ (map mk_inst prs) ++ (map mk_thunk prs) ++ concat (map mk_knot prs) where - mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts) + mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts) where - stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++ - [Method [Public] objectType enterName [vmArg] [excName] (javaExpr vmRETURN r)] + class_name = javaLocTypeName b + stmts = [Field [] (javaLocName b codeType) Nothing | (b,_) <- prs] ++ + [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)] - mk_inst (b,r) = var [Final] (javaGlobType b) (javaInstName b) - (New (javaGlobType b) [] Nothing) + mk_inst (b,r) = var [Final] (javaInstName b) + (mkNew (javaGlobType b) []) - mk_thunk (b,r) = var [Final] thunkType (javaName b) - (New thunkType [Var (javaInstName b) (Type "")] Nothing) + mk_thunk (b,r) = var [Final] (javaLocName b thunkType) + (New thunkType [Var (javaInstName b)] Nothing) - mk_knot (b,_) = [ExprStatement (Assign lhs rhs) + mk_knot (b,_) = [ ExprStatement (Assign lhs rhs) | (b',_) <- prs, - let lhs = Access (Var (javaInstName b) (Type "")) (javaName b'), - let rhs = Var (javaName b') (Type "") + let lhs = Access (Var (javaInstName b)) (javaName b'), + let rhs = Var (javaName b') ] +-- We are needlessly javaLam :: (Expr -> Expr) -> ([CoreBndr], CoreExpr) -> [Statement] javaLam r (bndrs, body) | null val_bndrs = javaExpr r body | otherwise = vmCOLLECT (length val_bndrs) this - ++ [var [Final] t (javaName n) (vmPOP t) | (n,t) <- val_bndrs] + ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs] ++ javaExpr r body where - val_bndrs = map (\ id -> (id,javaType id)) (filter isId bndrs) + val_bndrs = map javaName (filter isId bndrs) javaApp :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement] javaApp r (CoreSyn.App f a) as = javaApp r f (a:as) @@ -323,7 +330,6 @@ javaApp r (CoreSyn.Var f) as Just dc | length as == dataConRepArity dc -> -- Saturated constructors [Return (New (javaGlobType f) (javaArgs as) Nothing)] - ; other -> -- Not a saturated constructor java_apply r (CoreSyn.Var f) as } @@ -332,7 +338,6 @@ javaApp r f as = java_apply r f as java_apply :: (Expr -> Expr) -> CoreExpr -> [CoreExpr] -> [Statement] java_apply r f as = [ExprStatement (vmPUSH arg) | arg <- javaArgs as] ++ javaExpr r f - javaArgs :: [CoreExpr] -> [Expr] javaArgs args = [javaArg a | a <- args, isValArg a] @@ -350,33 +355,40 @@ javaArg e | exprIsValue e || exprIsTrivial e = newCode (javaExpr id e) \begin{code} true, this :: Expr -this = Var thisName (Type "") -true = Var "true" (PrimType PrimBoolean) +this = Var thisName +true = Var (Name "true" (PrimType PrimBoolean)) vmCOLLECT :: Int -> Expr -> [Statement] vmCOLLECT 0 e = [] -vmCOLLECT n e = [ExprStatement (Call varVM "COLLECT" - [Literal (IntLit (toInteger n)) (PrimType PrimInt), e])] +vmCOLLECT n e = [ExprStatement + (Call varVM collectName + [ Literal (IntLit (toInteger n)) + , e + ] + ) + ] vmPOP :: Type -> Expr -vmPOP ty = Call varVM ("POP" ++ suffix ty) [] +vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) [] vmPUSH :: Expr -> Expr -vmPUSH e = Call varVM ("PUSH" ++ suffix (exprType e)) [e] +vmPUSH e = Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e] vmRETURN :: Expr -> Expr vmRETURN e = case ty of - PrimType _ -> Call varVM ("RETURN" ++ suffix (exprType e)) [e] + PrimType _ -> Call varVM (Name ("RETURN" ++ suffix (exprType e)) + valueType + ) [e] _ -> e where ty = exprType e -var :: [Modifier] -> Type -> Name -> Expr -> Statement -var ms ty field_name value = Declaration (Field ms ty field_name (Just value)) +var :: [Modifier] -> Name -> Expr -> Statement +var ms field_name value = Declaration (Field ms field_name (Just value)) vmWHNF :: Expr -> Expr -vmWHNF e = Call varVM "WHNF" [e] +vmWHNF e = Call varVM whnfName [e] suffix :: Type -> String suffix (PrimType t) = primName t @@ -388,21 +400,21 @@ primName PrimChar = "char" primName _ = error "unsupported primitive" varVM :: Expr -varVM = Var vmName (Type "haskell.runtime.VMEngine") +varVM = Var vmName instanceOf :: Id -> DataCon -> Expr instanceOf x data_con - = InstanceOf (Var (javaName x) (Type "")) (javaConstrWkrType data_con) + = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con) newCode :: [Statement] -> Expr newCode [Return e] = e -newCode stmts = New codeType [] (Just [Method [Public] objectType enterName [vmArg] [excName] stmts]) +newCode stmts = New codeType [] (Just [Method [Public] enterName [vmArg] [excName] stmts]) newThunk :: Expr -> Expr newThunk e = New thunkType [e] Nothing vmArg :: Parameter -vmArg = Parameter [Final] (Type "haskell.runtime.VMEngine") vmName +vmArg = Parameter [Final] vmName \end{code} %************************************************************************ @@ -412,11 +424,15 @@ vmArg = Parameter [Final] (Type "haskell.runtime.VMEngine") vmName %************************************************************************ \begin{code} -exprType (Var _ t) = t -exprType (Literal _ t) = t -exprType (Cast t _) = t -exprType (New t _ _) = t -exprType _ = error "can't figure out an expression type" +exprType (Var (Name _ t)) = t +exprType (Literal lit) = litType lit +exprType (Cast t _) = t +exprType (New t _ _) = t +exprType _ = error "can't figure out an expression type" + +litType (IntLit i) = PrimType PrimInt +litType (CharLit i) = PrimType PrimChar +litType (StringLit i) = error "" \end{code} %************************************************************************ @@ -426,79 +442,122 @@ exprType _ = error "can't figure out an expression type" %************************************************************************ \begin{code} -codeName, thunkName, enterName, vmName,excName :: Name +codeName, excName, thunkName :: TypeName codeName = "haskell.runtime.Code" thunkName = "haskell.runtime.Thunk" -enterName = "ENTER" -vmName = "VM" -thisName = "this" -excName = "Exception" +excName = "java.lang.Exception" -fieldName :: Int -> Name -- Names for fields of a constructor -fieldName n = "f" ++ show n +enterName, vmName,thisName,collectName, whnfName :: Name +enterName = Name "ENTER" objectType +vmName = Name "VM" vmType +thisName = Name "this" (Type "") +collectName = Name "COLLECT" void +whnfName = Name "WNNF" objectType -javaName :: NamedThing a => a -> Name +fieldName :: Int -> Type -> Name -- Names for fields of a constructor +fieldName n ty = Name ("f" ++ show n) ty + +-- TODO: change to idToJavaName :: Id -> Name + +javaLocName :: Id -> Type -> Name +javaLocName n t = Name (getOccString n) t + +javaName :: Id -> Name javaName n = if isGlobalName n' - then moduleString (nameModule n') ++ "." ++ getOccString n - else getOccString n + then Name (javaGlobTypeName n) + (javaGlobType n) + else Name (getOccString n) + (Type "") + where + n' = getName n + +-- TypeName's are always global +javaGlobTypeName :: NamedThing a => a -> TypeName +javaGlobTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n) + where + n' = getName n + +javaLocTypeName :: NamedThing a => a -> TypeName +javaLocTypeName n = (moduleString (nameModule n') ++ "." ++ getOccString n) where n' = getName n -- this is used for getting the name of a class when defining it. +shortName :: TypeName -> TypeName shortName = reverse . takeWhile (/= '.') . reverse -javaConstrWkrName :: DataCon -> Name --- The function that makes the constructor -javaConstrWkrName con = javaName (dataConId con) +-- The function that makes the constructor name +javaConstrWkrName :: DataCon -> TypeName +javaConstrWkrName con = javaGlobTypeName (dataConId con) -javaInstName :: NamedThing a => a -> Name -- Makes x_inst for Rec decls -javaInstName n = getOccString n ++ "_inst" +javaInstName :: NamedThing a => a -> Name +javaInstName n = Name (getOccString n ++ "_inst") (Type "") \end{code} %************************************************************************ %* * -\subsection{Type mangling} +\subsection{Types and type mangling} %* * %************************************************************************ \begin{code} +-- Haskell RTS types +codeType, thunkType, valueType :: Type +codeType = Type codeName +thunkType = Type thunkName +valueType = Type "haskell.runtime.Value" +vmType = Type "haskell.runtime.VMEngine" + +-- Basic Java types +objectType, stringType :: Type +objectType = Type "java.lang.Object" +stringType = Type "java.lang.String" + +void :: Type +void = PrimType PrimVoid + +inttype :: Type +inttype = PrimType PrimInt + +chartype :: Type +chartype = PrimType PrimChar + +-- This is where we map from type to possible primitive +mkType "PrelGHC.Intzh" = inttype +mkType "PrelGHC.Charzh" = chartype +mkType other = Type other + -- This mapping a global haskell name (typically a function name) -- to the name of the class that handles it. --- The name must be global. So "Test.foo" maps to Type "Test.foo" +-- The name must be global. So foo in module Test maps to (Type "Test.foo") +-- TODO: change to Id javaGlobType :: NamedThing a => a -> Type javaGlobType n | '.' `notElem` name = error ("not using a fully qualified name for javaGlobalType: " ++ name) | otherwise = mkType name - where name = javaName n + where name = javaGlobTypeName n -- This takes an id, and finds the ids *type* (for example, Int, Bool, a, etc). javaType :: Id -> Type javaType id = case (idPrimRep id) of - IntRep -> PrimType PrimInt + IntRep -> inttype _ -> if isGlobalName (idName id) - then Type (javaName id) + then Type (javaGlobTypeName id) else objectType -- TODO: ?? for now ?? --- This is where we map from type to possible primitive -mkType "PrelGHC.Intzh" = PrimType PrimInt -mkType other = Type other - +-- This is used to get inside constructors, to find out the types +-- of the payload elements javaTauType :: Type.TauType -> Type javaTauType (TypeRep.TyConApp tycon _) = javaGlobType tycon javaTauType (TypeRep.NoteTy _ t) = javaTauType t javaTauType _ = objectType +-- The function that makes the constructor name javaConstrWkrType :: DataCon -> Type --- The function that makes the constructor javaConstrWkrType con = Type (javaConstrWkrName con) - -codeType, thunkType, objectType :: Type -objectType = Type ("java.lang.Object") -codeType = Type codeName -thunkType = Type thunkName \end{code} %************************************************************************ @@ -519,6 +578,7 @@ lifted inner class). when lifting. \begin{code} +{- type Bound = [Name] type Frees = [Name] @@ -820,4 +880,6 @@ liftNew (Env _ env) typ@(Type name) exprs -> New (Type nm) (map (\ v -> Var v (Type "")) args) Nothing _ -> error "pre-lifted constructor with arguments" listNew _ typ exprs = New typ exprs Nothing + +-} \end{code} diff --git a/ghc/compiler/javaGen/PrintJava.lhs b/ghc/compiler/javaGen/PrintJava.lhs index 3acd84c..e077d4e 100644 --- a/ghc/compiler/javaGen/PrintJava.lhs +++ b/ghc/compiler/javaGen/PrintJava.lhs @@ -27,7 +27,7 @@ compilationUnit :: CompilationUnit -> SDoc compilationUnit (Package n ds) = package n (decls ds) package = \n -> \ds -> - text "package" <+> name n <> text ";" + text "package" <+> packagename n <> text ";" $$ ds @@ -36,13 +36,13 @@ decls (d:ds) = decl d $$ decls ds decl = \d -> case d of - { Import n -> importDecl (name n) - ; Field mfs t n e -> field (modifiers mfs) (typ t) (name n) e - ; Constructor mfs n as ss -> constructor (modifiers mfs) (name n) (parameters as) (statements ss) - ; Method mfs t n as ts ss -> method (modifiers mfs) (typ t) (name n) (parameters as) (throws ts) (statements ss) + { Import n -> importDecl (packagename n) + ; Field mfs n e -> field (modifiers mfs) (nameTy n) (name n) e + ; Constructor mfs n as ss -> constructor (modifiers mfs) (typename n) (parameters as) (statements ss) + ; Method mfs n as ts ss -> method (modifiers mfs) (nameTy n) (name n) (parameters as) (throws ts) (statements ss) ; Comment s -> comment s - ; Interface mfs n is ms -> interface (modifiers mfs) (name n) (extends is) (decls ms) - ; Class mfs n x is ms -> clazz (modifiers mfs) (name n) (extends x) (implements is) (decls ms) + ; Interface mfs n is ms -> interface (modifiers mfs) (typename n) (extends is) (decls ms) + ; Class mfs n x is ms -> clazz (modifiers mfs) (typename n) (extends x) (implements is) (decls ms) } importDecl n = text "import" <+> n <> text ";" @@ -91,22 +91,27 @@ modifiers mfs = hsep (map modifier mfs) modifier mf = text $ map toLower (show mf) extends [] = empty -extends xs = text "extends" <+> hsep (punctuate comma (map name xs)) +extends xs = text "extends" <+> hsep (punctuate comma (map typename xs)) implements [] = empty -implements xs = text "implements" <+> hsep (punctuate comma (map name xs)) +implements xs = text "implements" <+> hsep (punctuate comma (map typename xs)) throws [] = empty -throws xs = text "throws" <+> hsep (punctuate comma (map name xs)) +throws xs = text "throws" <+> hsep (punctuate comma (map typename xs)) -name n = text n +name (Name n t) = text n + +nameTy (Name n t) = typ t + +typename n = text n +packagename n = text n parameters as = map parameter as -parameter (Parameter mfs t n) = modifiers mfs <+> typ t <+> name n +parameter (Parameter mfs n) = modifiers mfs <+> nameTy n <+> name n typ (PrimType s) = primtype s -typ (Type n) = name n +typ (Type n) = typename n typ (ArrayType t) = typ t <> text "[]" primtype PrimInt = text "int" @@ -116,8 +121,7 @@ primtype PrimLong = text "long" primtype PrimFloat = text "float" primtype PrimDouble = text "double" primtype PrimByte = text "byte" - - +primtype PrimVoid = text "void" statements ss = vcat (map statement ss) @@ -169,8 +173,8 @@ maybeExpr (Just e) = Just (expr e) expr = \e -> case e of - { Var n _ -> name n - ; Literal l _ -> literal l + { Var n -> name n + ; Literal l -> literal l ; Cast t e -> cast (typ t) e ; Access e n -> expr e <> text "." <> name n ; Assign l r -> assign (expr l) r