+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section{Generate Java}
-
-\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module PrintJava( compilationUnit ) where
-
-import Java
-import Outputable
-import Char( toLower )
-\end{code}
-
-\begin{code}
-indent :: SDoc -> SDoc
-indent = nest 2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Pretty printer}
-%* *
-%************************************************************************
-
-\begin{code}
-compilationUnit :: CompilationUnit -> SDoc
-compilationUnit (Package n ds) = package n (decls ds)
-
-package = \n -> \ds ->
- text "package" <+> packagename n <> text ";"
- $$
- ds
-
-decls [] = empty
-decls (d:ds) = decl d $$ decls ds
-
-decl = \d ->
- case d of
- { 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) (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 ";"
-
-field = \mfs -> \t -> \n -> \e ->
- case e of
- { Nothing -> mfs <+> t <+> n <> text ";"
- ; Just e -> lay [mfs <+> t <+> n <+> text "=", indent (expr e <> text ";")]
- where
- lay | isSimple e = hsep
- | otherwise = sep
- }
-
-constructor = \mfs -> \n -> \as -> \ss ->
- mfs <+> n <+> parens (hsep (punctuate comma as)) <+> text "{"
- $$ indent ss
- $$ text "}"
-
-method = \mfs -> \t -> \n -> \as -> \ts -> \ss ->
- mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> ts <+> text "{"
- $$ indent ss
- $$ text "}"
-
-comment = \ss ->
- text "/**"
- $$ indent (vcat [ text s | s <- ss])
- $$ text "**/"
-
-interface = \mfs -> \n -> \xs -> \ms ->
- mfs <+> n <+> xs <+> text "{"
- $$ indent ms
- $$ text "}"
-
-clazz = \mfs -> \n -> \x -> \is -> \ms ->
- mfs <+> text "class" <+> n <+> x <+> is <+> text "{"
- $$ indent ms
- $$ text "}"
-
-modifiers mfs = hsep (map modifier mfs)
-
-modifier mf = text $ map toLower (show mf)
-
-extends [] = empty
-extends xs = text "extends" <+> hsep (punctuate comma (map typename xs))
-
-implements [] = empty
-implements xs = text "implements" <+> hsep (punctuate comma (map typename xs))
-
-throws [] = empty
-throws xs = text "throws" <+> hsep (punctuate comma (map typename xs))
-
-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 n) = modifiers mfs <+> nameTy n <+> name n
-
-typ (PrimType s) = primtype s
-typ (Type n) = typename n
-typ (ArrayType t) = typ t <> text "[]"
-
-primtype PrimInt = text "int"
-primtype PrimBoolean = text "boolean"
-primtype PrimChar = text "char"
-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)
-
-statement = \s ->
- case s of
- { Skip -> skip
- ; Return e -> returnStat (expr e)
- ; Block ss -> vcat [statement s | s <- ss]
- ; ExprStatement e -> exprStatement (expr e)
- ; Declaration d -> declStatement (decl d)
- ; IfThenElse ecs s -> ifthenelse [ (expr e, statement s) | (e,s) <- ecs ] (maybe Nothing (Just .statement) s)
- ; Switch e as d -> switch (expr e) (arms as) (deflt d)
- }
-
-skip = empty
-
-returnStat e = sep [text "return", indent e <> semi]
-
-exprStatement e = e <> semi
-
-declStatement d = d
-
-ifthenelse ((e,s):ecs) ms = sep [ text "if" <+> parens e <+> text "{",
- indent s,
- thenelse ecs ms]
-
-thenelse ((e,s):ecs) ms = sep [ text "} else if" <+> parens e <+> text "{",
- indent s,
- thenelse ecs ms]
-
-thenelse [] Nothing = text "}"
-thenelse [] (Just s) = sep [text "} else {", indent s, text "}"]
-
-switch = \e -> \as -> \d ->
- text "switch" <+> parens e <+> text "{"
- $$ indent (as $$ d)
- $$ text "}"
-
-deflt Nothing = empty
-deflt (Just ss) = text "default:" $$ indent (statements ss)
-
-arms [] = empty
-arms ((e,ss):as) = text "case" <+> expr e <> colon
- $$ indent (statements ss)
- $$ arms as
-
-maybeExpr Nothing = Nothing
-maybeExpr (Just e) = Just (expr e)
-
-expr = \e ->
- case e of
- { 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
- ; New n es ds -> new (typ n) es (maybeClass ds)
- ; Raise n es -> text "raise" <+> text n
- <+> parens (hsep (punctuate comma (map expr es)))
- ; Call e n es -> call (expr e) (name n) es
- ; Op e1 o e2 -> op e1 o e2
- ; InstanceOf e t -> expr e <+> text "instanceof" <+> typ t
- }
-
-op = \e1 -> \o -> \e2 ->
- ( if isSimple e1
- then expr e1
- else parens (expr e1)
- )
- <+>
- text o
- <+>
- ( if isSimple e2
- then expr e2
- else parens (expr e2)
- )
-
-assign = \l -> \r ->
- if isSimple r
- then l <+> text "=" <+> (expr r)
- else l <+> text "=" $$ indent (expr r)
-
-cast = \t -> \e ->
- if isSimple e
- then parens (parens t <> expr e)
- else parens (parens t $$ indent (expr e))
-
-new n [] (Just ds) = sep [text "new" <+> n <+> text "()" <+> text "{",
- indent ds,
- text "}"]
-new n es Nothing = text "new" <+> n <> parens (hsep (punctuate comma (map expr es)))
-
-
-call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es)))
-
-literal = \l ->
- case l of
- { IntLit i -> text (show i)
- ; CharLit c -> text "(char)" <+> text (show c)
- ; StringLit s -> text ("\"" ++ s ++ "\"") -- strings are already printable
- }
-
-maybeClass Nothing = Nothing
-maybeClass (Just ds) = Just (decls ds)
-\end{code}
projects / ghc-hetmet.git / blobdiff