= Import [Name]
| Field [Modifier] Type Name (Maybe Expr)
| Constructor [Modifier] Name [Parameter] [Statement]
- -- Add Throws (list of Names)
- -- to Method
- | Method [Modifier] Type Name [Parameter] [Statement]
+ | Method [Modifier] Type Name [Parameter] [Name] [Statement]
| Comment [String]
| Interface [Modifier] Name [Name] [Decl]
| Class [Modifier] Name [Name] [Name] [Decl]
{ Import n -> Import n
; Field ms t n e -> Field (m:ms) t n e
; Constructor ms n as ss -> Constructor (m:ms) n as ss
- ; Method ms t n as ss -> Method (m:ms) t n as ss
+ ; Method ms t n as ts ss -> Method (m:ms) t 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
javaGen mod import_mods tycons binds
= liftCompilationUnit package
where
- decls = [Import [moduleString mod] | mod <- import_mods] ++
+ decls = [Import ["haskell","runtime","*"]] ++
+ [Import [moduleString mod] | mod <- import_mods] ++
concat (map javaTyCon (filter isDataTyCon tycons)) ++
concat (map javaTopBind binds)
package = Package (moduleString mod) decls
where
constr_jname = javaConstrWkrName data_con
constr_jtype = javaConstrWkrType data_con
- enter_meth = Method [Public] objectType enterName [] stmts
+ enter_meth = Method [Public] objectType enterName [] [papExcName] stmts
n_val_args = dataConRepArity data_con
field_names = map fieldName [1..n_val_args]
field_decls = [Field [Public] objectType f Nothing | f <- field_names]
java_top_bind bndr rhs
= Class [Public] (javaName bndr) [] [codeName] [enter_meth]
where
- enter_meth = Method [Public] objectType enterName [] (javaExpr rhs)
+ enter_meth = Method [Public] objectType enterName [] [papExcName]
+ (javaExpr rhs)
\end{code}
mk_class (b,r) = Declaration (Class [] (javaName b) [] [codeName] stmts)
where
stmts = [Field [] codeType (javaName b) Nothing | (b,_) <- prs] ++
- [Method [Public] objectType enterName [] (javaExpr r)]
+ [Method [Public] objectType enterName [] [papExcName] (javaExpr r)]
mk_inst (b,r) = var [Final] (javaType b) (javaInstName b)
(New (javaType b) [] Nothing)
newCode :: [Statement] -> Expr
newCode [Return e] = e
-newCode stmts = New codeType [] (Just [Method [Public] objectType enterName [] stmts])
+newCode stmts = New codeType [] (Just [Method [Public] objectType enterName [] [papExcName] stmts])
newThunk :: Expr -> Expr
newThunk e = New thunkType [e] Nothing
%************************************************************************
\begin{code}
-codeName, enterName, vmName :: Name
+codeName, enterName, vmName,papExcName :: Name
codeName = "Code"
thunkName = "Thunk"
enterName = "ENTER"
vmName = "VM"
thisName = "this"
+papExcName = "PartialApplicationException"
fieldName :: Int -> Name -- Names for fields of a constructor
fieldName n = "f" ++ show n
; (ss,_) <- liftStatements (combineEnv env newBound) ss
; return (Constructor mfs n (liftParameters env as) ss)
}
- ; Method mfs t n as ss ->
+ ; Method mfs t n as ts ss ->
do { let newBound = getBoundAtParameters as
; (ss,_) <- liftStatements (combineEnv env newBound) ss
- ; return (Method mfs (liftType env t) n (liftParameters env as) ss)
+ ; return (Method mfs (liftType env t) n (liftParameters env as) ts ss)
}
; Comment s -> return (Comment s)
; Interface mfs n is ms -> error "interfaces not supported"
new env typ [] (Just inner) =
-- anon. inner class
do { innerName <- genAnonInnerClassName
- ; frees <- liftClass env innerName inner [unType typ] []
+ ; frees <- liftClass env innerName inner [] [unType typ]
; return (New (Type [innerName]) [ Var name | name <- frees ] Nothing)
}
where unType (Type [name]) = name
{ Import n -> importDecl (hcat (punctuate dot (map text 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 ss -> method (modifiers mfs) (typ t) (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)
; 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)
$$ indent ss
$$ text "}"
-method = \mfs -> \t -> \n -> \as -> \ss ->
- mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> text "{"
+method = \mfs -> \t -> \n -> \as -> \ts -> \ss ->
+ mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> ts <+> text "{"
$$ indent ss
$$ text "}"
implements [] = empty
implements xs = text "implements" <+> hsep (punctuate comma (map name xs))
+throws [] = empty
+throws xs = text "throws" <+> hsep (punctuate comma (map name xs))
+
name ns = text ns
parameters as = map parameter as