compiler/javaGen/PrintJava.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Generate Java}
   5
   6 \begin{code}
   7 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  12 -- for details
  13
  14 module PrintJava( compilationUnit ) where
  15
  16 import Java
  17 import Outputable
  18 import Char( toLower )
  19 \end{code}
  20
  21 \begin{code}
  22 indent :: SDoc -> SDoc
  23 indent = nest 2
  24 \end{code}
  25
  26 %************************************************************************
  27 %*                                                                      *
  28 \subsection{Pretty printer}
  29 %*                                                                      *
  30 %************************************************************************
  31
  32 \begin{code}
  33 compilationUnit :: CompilationUnit -> SDoc
  34 compilationUnit (Package n ds) = package n (decls ds)
  35
  36 package = \n -> \ds ->
  37   text "package" <+> packagename n <> text ";"
  38   $$
  39   ds
  40
  41 decls []     = empty
  42 decls (d:ds) = decl d $$ decls ds
  43
  44 decl = \d ->
  45   case d of
  46     { Import n -> importDecl (packagename n)
  47     ; Field mfs n e -> field (modifiers mfs) (nameTy n) (name n) e
  48     ; Constructor mfs n as ss -> constructor (modifiers mfs) (typename n) (parameters as) (statements ss)
  49     ; Method mfs n as ts ss -> method (modifiers mfs) (nameTy n) (name n) (parameters as) (throws ts) (statements ss)
  50     ; Comment s -> comment s
  51     ; Interface mfs n is ms -> interface (modifiers mfs) (typename n) (extends is) (decls ms)
  52     ; Class mfs n x is ms -> clazz (modifiers mfs) (typename n) (extends x) (implements is) (decls ms)
  53     }
  54
  55 importDecl n = text "import" <+> n <> text ";"
  56
  57 field = \mfs -> \t -> \n -> \e ->
  58   case e of
  59     { Nothing -> mfs <+> t <+> n <> text ";"
  60     ; Just e  -> lay [mfs <+> t <+> n <+> text "=", indent (expr e <> text ";")]
  61              where
  62                 lay | isSimple e = hsep
  63                     | otherwise  = sep
  64     }
  65
  66 constructor = \mfs -> \n -> \as -> \ss ->
  67   mfs <+> n <+> parens (hsep (punctuate comma as)) <+> text "{"
  68   $$ indent ss
  69   $$ text "}"
  70
  71 method = \mfs -> \t -> \n -> \as -> \ts -> \ss ->
  72   mfs <+> t <+> n <+> parens (hsep (punctuate comma as)) <+> ts <+> text "{"
  73   $$ indent ss
  74   $$ text "}"
  75
  76 comment = \ss ->
  77   text "/**"
  78   $$ indent (vcat [ text s | s <- ss])
  79   $$ text "**/"
  80
  81 interface = \mfs -> \n -> \xs -> \ms ->
  82   mfs <+> n <+> xs <+> text "{"
  83   $$ indent ms
  84   $$ text "}"
  85
  86 clazz = \mfs -> \n -> \x -> \is -> \ms ->
  87   mfs <+> text "class" <+> n <+> x <+> is <+> text "{"
  88   $$ indent ms
  89   $$ text "}"
  90
  91 modifiers mfs = hsep (map modifier mfs)
  92
  93 modifier mf = text $ map toLower (show mf)
  94
  95 extends [] = empty
  96 extends xs = text "extends" <+> hsep (punctuate comma (map typename xs))
  97
  98 implements [] = empty
  99 implements xs = text "implements" <+> hsep (punctuate comma (map typename xs))
 100
 101 throws [] = empty
 102 throws xs = text "throws" <+> hsep (punctuate comma (map typename xs))
 103
 104 name (Name n t)   = text n
 105
 106 nameTy (Name n t) = typ t
 107
 108 typename n        = text n
 109 packagename n     = text n
 110
 111 parameters as = map parameter as
 112
 113 parameter (Parameter mfs n) = modifiers mfs <+> nameTy n <+> name n
 114
 115 typ (PrimType s)  = primtype s
 116 typ (Type n)      = typename n
 117 typ (ArrayType t) = typ t <> text "[]"
 118
 119 primtype PrimInt     = text "int"
 120 primtype PrimBoolean = text "boolean"
 121 primtype PrimChar    = text "char"
 122 primtype PrimLong    = text "long"
 123 primtype PrimFloat   = text "float"
 124 primtype PrimDouble  = text "double"
 125 primtype PrimByte    = text "byte"
 126 primtype PrimVoid    = text "void"
 127
 128 statements ss = vcat (map statement ss)
 129
 130 statement = \s ->
 131   case s of
 132     { Skip -> skip
 133     ; Return e -> returnStat (expr e)
 134     ; Block ss -> vcat [statement s | s <- ss]
 135     ; ExprStatement e -> exprStatement (expr e)
 136     ; Declaration d -> declStatement (decl d)
 137     ; IfThenElse ecs s -> ifthenelse [ (expr e, statement s) | (e,s) <- ecs ] (maybe Nothing (Just .statement) s)
 138     ; Switch e as d -> switch (expr e) (arms as) (deflt d)
 139     }
 140
 141 skip = empty
 142
 143 returnStat e = sep [text "return", indent e <> semi]
 144
 145 exprStatement e = e <> semi
 146
 147 declStatement d = d
 148
 149 ifthenelse ((e,s):ecs) ms = sep [ text "if" <+> parens e <+> text "{",
 150                                   indent s,
 151                                   thenelse ecs ms]
 152
 153 thenelse ((e,s):ecs) ms = sep [ text "} else if" <+> parens e <+> text "{",
 154                                 indent s,
 155                                 thenelse ecs ms]
 156
 157 thenelse [] Nothing  = text "}"
 158 thenelse [] (Just s) = sep [text "} else {", indent s, text "}"]
 159
 160 switch = \e -> \as -> \d ->
 161   text "switch" <+> parens e <+> text "{"
 162   $$ indent (as $$ d)
 163   $$ text "}"
 164
 165 deflt Nothing   = empty
 166 deflt (Just ss) = text "default:" $$ indent (statements ss)
 167
 168 arms [] = empty
 169 arms ((e,ss):as) = text "case" <+> expr e <> colon
 170                    $$ indent (statements ss)
 171                    $$ arms as
 172
 173 maybeExpr Nothing  = Nothing
 174 maybeExpr (Just e) = Just (expr e)
 175
 176 expr = \e ->
 177  case e of
 178    { Var n -> name n
 179    ; Literal l -> literal l
 180    ; Cast t e -> cast (typ t) e
 181    ; Access e n -> expr e <> text "." <> name n
 182    ; Assign l r -> assign (expr l) r
 183    ; New n es ds -> new (typ n) es (maybeClass ds)
 184    ; Raise n es  -> text "raise" <+> text n
 185                         <+> parens (hsep (punctuate comma (map expr es)))
 186    ; Call e n es -> call (expr e) (name n) es
 187    ; Op e1 o e2 -> op e1 o e2
 188    ; InstanceOf e t -> expr e <+> text "instanceof" <+> typ t
 189    }
 190
 191 op = \e1 -> \o -> \e2 ->
 192   ( if isSimple e1
 193     then expr e1
 194     else parens (expr e1)
 195   )
 196   <+>
 197   text o
 198   <+>
 199   ( if isSimple e2
 200     then expr e2
 201     else parens (expr e2)
 202   )
 203
 204 assign = \l -> \r ->
 205   if isSimple r
 206   then l <+> text "=" <+> (expr r)
 207   else l <+> text "=" $$ indent (expr r)
 208
 209 cast = \t -> \e ->
 210   if isSimple e
 211   then parens (parens t <> expr e)
 212   else parens (parens t $$ indent (expr e))
 213
 214 new n [] (Just ds) = sep [text "new" <+> n <+> text "()" <+> text "{",
 215                              indent ds,
 216                              text "}"]
 217 new n es Nothing = text "new" <+> n <> parens (hsep (punctuate comma (map expr es)))
 218
 219
 220 call e n es = e <> dot <> n <> parens (hsep (punctuate comma (map expr es)))
 221
 222 literal = \l ->
 223   case l of
 224     { IntLit i    -> text (show i)
 225     ; CharLit c   -> text "(char)" <+> text (show c)
 226     ; StringLit s -> text ("\"" ++ s ++ "\"")   -- strings are already printable
 227     }
 228
 229 maybeClass Nothing   = Nothing
 230 maybeClass (Just ds) = Just (decls ds)
 231 \end{code}