Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

3 files changed, 1559 insertions, 0 deletions

diff --git a/compiler/javaGen/Java.lhs b/compiler/javaGen/Java.lhs
new file mode 100644
index 0000000000..368be03fc1
--- /dev/null
+++ b/compiler/javaGen/Java.lhs
@@ -0,0 +1,169 @@
+Anbstract syntax for Java subset that is the target of Mondrian.
+The syntax has been taken from "The Java Language Specification".
+
+(c) Erik Meijer & Arjan van IJzendoorn
+
+November 1999
+
+Major reworking to be usable for the intermeduate (GOO) language
+for the backend of GHC and to target languauges like Java sucessfully.
+-- Andy Gill
+
+\begin{code}
+module Java where
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Java type declararations}
+%*									*
+%************************************************************************
+
+\begin{code}
+data CompilationUnit
+  = Package PackageName [Decl]
+    deriving (Show)
+    
+data Decl
+ = Import PackageName
+ | Field [Modifier] Name (Maybe Expr)
+ | Constructor [Modifier] TypeName [Parameter] [Statement]
+ | Method [Modifier] Name [Parameter] [Exception] [Statement]
+ | Comment [String]
+ | Interface [Modifier] TypeName [TypeName] [Decl]
+ | Class [Modifier] TypeName [TypeName] [TypeName] [Decl]
+   deriving (Show)
+
+data Parameter
+ = Parameter [Modifier] Name
+   deriving (Show)
+   
+data Statement
+  = Skip
+  | Return Expr		-- This always comes last in a list
+			-- of statements, and it is understood
+			-- you might change this to something
+			-- else (like a variable assignment)
+			-- if this is not top level statements.
+  | Block [Statement]
+  | ExprStatement Expr	-- You are never interested in the result
+			-- of an ExprStatement
+  | Declaration Decl -- variable = inner Field, Class = innerclass
+  | IfThenElse [(Expr,Statement)] (Maybe Statement)
+  | Switch Expr [(Expr, [Statement])] (Maybe [Statement])
+    deriving (Show)
+
+data Expr 
+  = Var Name
+  | Literal Lit
+  | Cast Type Expr
+  | Access Expr Name
+  | Assign Expr Expr
+  | InstanceOf Expr Type
+  | Call Expr Name [Expr]
+  | Op Expr String Expr
+  | Raise TypeName [Expr]
+  | New Type [Expr] (Maybe [Decl]) -- anonymous innerclass
+    deriving (Show)
+    
+data Modifier 
+  = Public | Protected | Private
+  | Static
+  | Abstract | Final | Native | Synchronized | Transient | Volatile
+  deriving (Show, Eq, Ord)
+
+-- A type is used to refer in general to the shape of things,
+-- or a specific class. Never use a name to refer to a class,
+-- always use a type.
+
+data Type 
+  = PrimType  PrimType
+  | ArrayType Type
+  | Type      TypeName
+    deriving (Show, Eq)
+
+data PrimType 
+  = PrimInt 
+  | PrimBoolean
+  | PrimChar
+  | PrimLong
+  | PrimFloat
+  | PrimDouble
+  | PrimByte
+  | PrimVoid
+    deriving (Show, Eq)
+
+type PackageName = String	-- A package name
+				-- like "java.awt.Button"
+
+type Exception   = TypeName	-- A class name that must be an exception.
+
+type TypeName    = String	-- a fully qualified type name
+				-- like "java.lang.Object".
+				-- has type "Type <the name>"
+
+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 arg x result type.
+				--
+				-- Thinking:
+				-- ... foo1.foo2(...).foo3 ...
+				-- here you want to know the *result*
+				-- after calling foo1, then foo2,
+				-- then foo3.
+
+instance Eq Name where
+   (Name nm _) == (Name nm' _) = nm == nm'
+
+
+instance Ord Name where
+   (Name nm _) `compare` (Name nm' _) = nm `compare` nm'
+
+
+data Lit
+  = IntLit Integer	-- unboxed
+  | CharLit Int 	-- unboxed
+  | StringLit String	-- java string
+  deriving Show
+
+addModifier :: Modifier -> Decl -> Decl
+addModifier = \m -> \d ->
+ case d of
+   { Import n -> Import n
+   ; Field ms n e -> Field (m:ms) n e  
+   ; Constructor ms n as ss -> Constructor (m:ms) n as 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
+
+isSimple :: Expr -> Bool
+isSimple = \e ->
+  case e of
+   { Cast t e -> isSimple e
+   ; Access e n -> isSimple e
+   ; Assign l r -> isSimple l && isSimple r
+   ; InstanceOf e t -> isSimple e
+   ; Call e n es -> isSimple e && areSimple es
+   ; Op e1 o e2 -> False
+   ; New n es Nothing -> areSimple es
+   ; New n es (Just ds) -> False
+   ; otherwise -> True
+   }
+\end{code}
diff --git a/compiler/javaGen/JavaGen.lhs b/compiler/javaGen/JavaGen.lhs
new file mode 100644
index 0000000000..a3925b18e8
--- /dev/null
+++ b/compiler/javaGen/JavaGen.lhs
@@ -0,0 +1,1166 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
+%
+\section{Generate Java}
+
+Name mangling for Java.
+~~~~~~~~~~~~~~~~~~~~~~
+
+Haskell has a number of namespaces. The Java translator uses
+the standard Haskell mangles (see OccName.lhs), and some extra
+mangles.
+
+All names are hidden inside packages.
+
+module name:
+  - becomes a first level java package.
+  - can not clash with java, because haskell modules are upper case,
+     java default packages are lower case.
+
+function names: 
+  - these turn into classes
+  - java keywords (eg. private) have the suffix "zdk" ($k) added.
+
+data *types*
+  - These have a base class, so need to appear in the 
+    same name space as other object. for example data Foo = Foo
+  - We add a postfix to types: "zdc" ($c)
+  - Types are upper case, so never clash with keywords
+
+data constructors
+  - There are tWO classes for each Constructor
+   (1) - Class with the payload extends the relevent datatype baseclass.
+       - This class has the prefix zdw ($w)
+   (2) - Constructor *wrapper* just use their own name.
+    - Constructors are upper case, so never clash with keywords
+    - So Foo would become 2 classes.
+	* Foo		-- the constructor wrapper
+	* zdwFoo	-- the worker, with the payload
+
+
+$i  for instances.
+$k  for keyword nameclash avoidance.
+
+\begin{code}
+module JavaGen( javaGen ) where
+
+import Java
+
+import Literal	( Literal(..) )
+import Id	( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep
+		, isPrimOpId_maybe )
+import Name	( NamedThing(..), getOccString, isExternalName, isInternalName
+		, nameModule )
+import PrimRep  ( PrimRep(..) )
+import DataCon	( DataCon, dataConRepArity, dataConRepArgTys, dataConWorkId )
+import qualified Type
+import qualified CoreSyn
+import CoreSyn	( CoreBind, CoreExpr, CoreAlt, CoreBndr,
+		  Bind(..), AltCon(..), collectBinders, isValArg
+		)
+import TysWiredIn	( boolTy, trueDataCon, falseDataCon )
+import qualified CoreUtils
+import Module	( Module, moduleString )
+import TyCon	( TyCon, isDataTyCon, tyConDataCons )
+import Outputable
+
+import Maybe
+import PrimOp
+import Util     ( lengthIs, notNull )
+
+#include "HsVersions.h"
+
+\end{code}
+
+
+\begin{code}
+javaGen :: Module -> [Module] -> [TyCon] -> [CoreBind] -> CompilationUnit
+
+javaGen mod import_mods tycons binds
+  = liftCompilationUnit package
+  where
+    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
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Type declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+javaTyCon :: TyCon -> [Decl]
+--  	public class List {}
+--
+--	public class $wCons extends List {
+--		Object f1; Object f2
+--	}
+--	public class $wNil extends List {}
+
+javaTyCon tycon 
+  = tycon_jclass : concat (map constr_class constrs)
+  where
+    constrs = tyConDataCons tycon
+    tycon_jclass_jname =  javaTyConTypeName tycon ++ "zdc"
+    tycon_jclass = Class [Public] (shortName tycon_jclass_jname) [] [] []
+
+    constr_class data_con
+	= [ Class [Public] constr_jname [tycon_jclass_jname] []
+				(field_decls ++ [cons_meth,debug_meth])
+	  ]
+	where
+	  constr_jname = shortName (javaConstrWkrName data_con)
+
+	  field_names  = constrToFields data_con
+	  field_decls  = [ Field [Public] n Nothing 
+			 | n <- field_names
+			 ]
+
+	  cons_meth    = mkCons constr_jname field_names
+
+	  debug_meth   = Method [Public] (Name "toString" stringType)
+					 []
+					 []
+		       (  [ Declaration (Field [] txt Nothing) ]
+		       ++ [ ExprStatement
+				(Assign (Var txt)
+					    (mkStr
+						("( " ++ 
+						  getOccString data_con ++ 
+						  " ")
+				       	     )
+				)
+			  ]
+		       ++ [ ExprStatement
+				(Assign (Var txt)
+				   (Op (Var txt)
+				        "+" 
+				       (Op (Var n) "+" litSp)
+				   )
+				)
+			  | n <- field_names
+			  ]
+		       ++ [ Return (Op (Var txt)
+				        "+" 
+				      (mkStr ")")
+				   )
+			  ]
+		       )
+
+	  litSp    = mkStr " "
+	  txt      = Name "__txt" stringType
+	 
+
+-- This checks to see the type is reasonable to call new with.
+-- primitives might use a static method later.
+mkNew :: Type -> [Expr] -> Expr
+mkNew t@(PrimType primType) _  = error "new primitive -- fix it???"
+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 primRepToType
+			          (map Type.typePrimRep
+				       (dataConRepArgTys cons)
+				  )
+			     )
+	]
+
+mkCons :: TypeName -> [Name] -> Decl
+mkCons name args = Constructor [Public] name
+	[ Parameter [] n | n <- args ]
+	[ ExprStatement (Assign 
+			   (Access this n)
+			   (Var n)
+			 )
+		    | n <- args ]
+
+mkStr :: String -> Expr
+mkStr str = Literal (StringLit str)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings}
+%*									*
+%************************************************************************
+
+\begin{code}
+javaTopBind :: CoreBind -> [Decl]
+javaTopBind (NonRec bndr rhs) = [java_top_bind bndr rhs]
+javaTopBind (Rec prs) 	      = [java_top_bind bndr rhs | (bndr,rhs) <- prs]
+
+java_top_bind :: Id -> CoreExpr -> Decl
+-- 	public class f implements Code {
+--	  public Object ENTER() { ...translation of rhs... }
+--	}
+java_top_bind bndr rhs
+  = Class [Public] (shortName (javaIdTypeName bndr))
+		[] [codeName] [enter_meth]
+  where
+    enter_meth = Method [Public]
+			enterName
+			[vmArg]
+			[excName]
+			(javaExpr vmRETURN rhs)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Expressions}
+%*									*
+%************************************************************************
+
+\begin{code}
+javaVar :: Id -> Expr
+javaVar v | isExternalName (idName v) = mkNew (javaIdType v) []
+	  | otherwise	  	    =   Var (javaName v)
+
+javaLit :: Literal.Literal -> Expr
+javaLit (MachInt i)  = Literal (IntLit (fromInteger i))
+javaLit (MachChar c) = Literal (CharLit c)
+javaLit (MachStr fs) = Literal (StringLit str)
+   where
+	str = concatMap renderString (unpackFS fs) ++ "\\000"
+	-- This should really handle all the chars 0..31.
+	renderString '\NUL' = "\\000"
+	renderString other  = [other]
+
+javaLit other	     = pprPanic "javaLit" (ppr other)
+
+-- Pass in the 'shape' of the result.
+javaExpr :: (Expr -> Statement) -> CoreExpr -> [Statement]
+-- Generate code to apply the value of 
+-- the expression to the arguments aleady on the stack
+javaExpr r (CoreSyn.Var v)   = [r (javaVar v)]
+javaExpr r (CoreSyn.Lit l)   = [r (javaLit l)]
+javaExpr r (CoreSyn.App f a) = javaApp r f [a]
+javaExpr r e@(CoreSyn.Lam _ _) = javaLam r (collectBinders e)
+javaExpr r (CoreSyn.Case e x alts) = javaCase r e x alts
+javaExpr r (CoreSyn.Let bind body) = javaBind bind ++ javaExpr r body
+javaExpr r (CoreSyn.Note _ e)	 = javaExpr r e
+
+javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement]
+-- 	case e of x { Nil      -> r1
+--		      Cons p q -> r2 }
+-- ==>
+--	final Object x = VM.WHNF(...code for e...)
+--	else if x instance_of Nil {
+--		...translation of r1...
+--	} else if x instance_of Cons {
+--		final Object p = ((Cons) x).f1
+--		final Object q = ((Cons) x).f2
+--		...translation of r2...
+--	} else throw java.lang.Exception
+
+-- This first special case happens a lot, typically
+-- during dictionary deconstruction.
+-- We need to access at least *one* field, to check to see
+-- if we have correct constructor.
+-- If we've got the wrong one, this is _|_, and the
+-- casting will catch this with an exception.
+
+javaCase r e x [(DataAlt d,bs,rhs)] | notNull bs
+  = java_expr PushExpr e ++
+    [ var [Final] (javaName x)
+	          (whnf primRep (vmPOP (primRepToType primRep))) ] ++
+    bind_args d bs ++
+    javaExpr r rhs
+   where      
+     primRep = idPrimRep x
+     whnf PtrRep = vmWHNF	-- needs evaluation
+     whnf _      = id		-- anything else does notg
+
+     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)
+		      ]
+   
+javaCase r e x alts
+  | isIfThenElse && isPrimCmp
+  = javaIfThenElse r (fromJust maybePrim) tExpr fExpr
+  | otherwise
+  = java_expr PushExpr e ++
+       [ var [Final] (javaName x)
+		           (whnf primRep (vmPOP (primRepToType primRep)))
+       , IfThenElse (map mk_alt con_alts) (Just default_code)
+       ]
+  where
+     isIfThenElse = CoreUtils.exprType e `Type.eqType` boolTy
+		    -- also need to check that x is not free in
+		    -- any of the branches.
+     maybePrim    = findCmpPrim e []
+     isPrimCmp    = isJust maybePrim
+     (_,_,tExpr)  = CoreUtils.findAlt (DataAlt trueDataCon) alts 
+     (_,_,fExpr)  = CoreUtils.findAlt (DataAlt falseDataCon) alts 
+
+     primRep = idPrimRep x
+     whnf PtrRep = vmWHNF	-- needs evaluation
+     whnf _      = id
+
+     (con_alts, maybe_default) = CoreUtils.findDefault alts
+     default_code = case maybe_default of
+			Nothing  -> ExprStatement (Raise excName [Literal (StringLit "case failure")])
+			Just rhs -> Block (javaExpr r rhs)
+
+     mk_alt (DataAlt d,  bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs))
+     mk_alt (LitAlt lit, bs, rhs) = (eqLit lit     , Block (javaExpr r rhs))
+
+
+     eqLit (MachInt n) = Op (Literal (IntLit n))
+
+			    "=="
+			    (Var (javaName x))
+     eqLit (MachChar n) = Op (Literal (CharLit n))
+			    "=="
+			    (Var (javaName x))
+     eqLit other       = pprPanic "eqLit" (ppr other)
+
+     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)
+		      ]
+
+javaIfThenElse r cmp tExpr fExpr 
+{-
+ - Now what we need to do is generate code for the if/then/else.
+ - [all arguments are already check for simpleness (Var or Lit).]
+ - 
+ - if (<prim> arg1 arg2 arg3 ...) {
+ -	trueCode
+ -  } else {
+ -	falseCode
+ - }
+ -}
+ = [IfThenElse [(cmp,j_tExpr)] (Just j_fExpr)]
+ where
+   j_tExpr, j_fExpr :: Statement
+   j_tExpr = Block (javaExpr r tExpr)
+   j_fExpr = Block (javaExpr r fExpr)
+
+javaBind (NonRec x rhs)
+{-
+	x = ...rhs_x...
+  ==>
+	final Object x = new Thunk( new Code() { ...code for rhs_x... } )
+-}
+
+  = java_expr (SetVar name) rhs
+  where
+    name = case coreTypeToType rhs of
+	    ty@(PrimType _) -> javaName x `withType` ty
+	    _               -> javaName x `withType` codeType
+
+javaBind (Rec prs)
+{- 	rec { x = ...rhs_x...; y = ...rhs_y... }
+  ==>
+	class x implements Code {
+	  Code x, y;
+	  public Object ENTER() { ...code for rhs_x...}
+	}
+	...ditto for y...
+
+	final x x_inst = new x();
+	...ditto for y...
+
+	final Thunk x = new Thunk( x_inst );
+	...ditto for y...
+
+	x_inst.x = x;
+	x_inst.y = y;
+	...ditto for y...
+-}
+  = (map mk_class prs) ++ (map mk_inst prs) ++ 
+    (map mk_thunk prs) ++ concat (map mk_knot prs)
+  where
+    mk_class (b,r) = Declaration (Class [] class_name [] [codeName] stmts)
+		   where
+		     class_name = javaIdTypeName b
+		     stmts = [Field [] (javaName b `withType` codeType) Nothing | (b,_) <- prs] ++
+			     [Method [Public] enterName [vmArg] [excName] (javaExpr vmRETURN r)]	
+
+    mk_inst (b,r) = var [Final] name (mkNew ty [])
+	where
+	   name@(Name _ ty)  = javaInstName b
+
+    mk_thunk (b,r) = var [Final] (javaName b `withType` codeType)
+			 (mkNew thunkType [Var (javaInstName b)])
+
+    mk_knot (b,_) = [ ExprStatement (Assign lhs rhs) 
+		    | (b',_) <- prs,
+		      let lhs = Access (Var (javaInstName b)) (javaName b'),
+		      let rhs = Var (javaName b')
+		    ]
+
+javaLam :: (Expr -> Statement) -> ([CoreBndr], CoreExpr) -> [Statement]
+javaLam r (bndrs, body)
+  | null val_bndrs = javaExpr r body
+  | otherwise
+  =  vmCOLLECT (length val_bndrs) this
+  ++ [var [Final] n (vmPOP t) | n@(Name _ t) <- val_bndrs]
+  ++ javaExpr r body
+  where
+    val_bndrs = map javaName (filter isId bndrs)
+
+javaApp :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
+javaApp r (CoreSyn.App f a) as 
+	| isValArg a = javaApp r f (a:as)
+	| otherwise  = javaApp r f as
+javaApp r (CoreSyn.Var f) as 
+  = case isDataConWorkId_maybe f of {
+	Just dc | as `lengthIs` dataConRepArity dc
+	 -- NOTE: Saturated constructors never returning a primitive at this point
+	 --
+	 -- We push the arguments backwards, because we are using
+	 -- the (ugly) semantics of the order of evaluation of arguments,
+	 -- to avoid making up local names. Oh to have a namesupply...
+	 --
+		-> javaArgs (reverse as) ++
+		   [r (New (javaIdType f)
+			   (javaPops as)
+			   Nothing
+		       )
+		   ]
+	        | otherwise ->
+		   --  build a local 
+		   let stmts = 
+			  vmCOLLECT (dataConRepArity dc) this ++
+			[ vmRETURN
+			   (New (javaIdType f)
+				[ vmPOP ty | (Name _ ty) <- constrToFields dc ]
+				Nothing
+			    )
+			]
+		   in javaArgs (reverse as) ++ [r (newCode stmts)]
+    ; other -> java_apply r (CoreSyn.Var f) as
+    }
+	
+javaApp r f as = java_apply r f as
+
+-- This means, given a expression an a list of arguments,
+-- generate code for "pushing the arguments on the stack,
+--  and the executing the expression."
+
+java_apply :: (Expr -> Statement) -> CoreExpr -> [CoreExpr] -> [Statement]
+java_apply r f as = javaArgs as ++ javaExpr r f
+
+-- This generates statements that have the net effect
+-- of pushing values (perhaps thunks) onto the stack.
+
+javaArgs :: [CoreExpr] -> [Statement]
+javaArgs args = concat [ java_expr PushExpr a | a <- args, isValArg a]
+
+javaPops :: [CoreExpr] -> [Expr]
+javaPops args = [ vmPOP (primRepToType (Type.typePrimRep (CoreUtils.exprType a)))
+		| a <- args 
+		, isValArg a
+		]
+
+
+-- The result is a list of statments that have the effect of
+-- pushing onto the stack (via one of the VM.PUSH* commands)
+-- the argument, (or returning, or setting a variable)
+-- perhaps thunked.
+
+{- This is mixing two things.
+ (1) Optimizations for things like primitives, whnf calls, etc.
+ (2) If something needs a thunk constructor round it.
+ - Seperate them at some point!
+ -}
+data ExprRetStyle = SetVar Name | PushExpr | ReturnExpr
+
+java_expr :: ExprRetStyle -> CoreExpr -> [Statement]
+java_expr _ (CoreSyn.Type t) = pprPanic "java_expr" (ppr t)
+java_expr ret e
+   | isPrimCall = [push (fromJust maybePrim)]
+	-- This is a shortcut, 
+	-- basic names and literals do not need a code block
+	-- to compute the value.
+   | isPrim primty && CoreUtils.exprIsTrivial e = javaExpr push e
+   | isPrim primty =
+ 	  let expr  = javaExpr vmRETURN e
+	      code  = access (vmWHNF (newCode expr)) (primRepToType primty)
+	  in [push code]
+   | otherwise =
+ 	  let expr  = javaExpr vmRETURN e
+	      code  = newCode expr
+	      code' = if CoreUtils.exprIsValue e 
+		      || CoreUtils.exprIsTrivial e 
+		      || isPrim primty
+		      then code
+		      else newThunk code
+	  in [push code']
+   where
+	maybePrim  = findFnPrim e []
+	isPrimCall = isJust maybePrim
+
+	push e = case ret of
+		  SetVar name -> var [Final] name e
+		  PushExpr -> vmPUSH e
+		  ReturnExpr -> vmRETURN e
+	corety = CoreUtils.exprType e
+	primty = Type.typePrimRep corety
+	isPrim PtrRep  = False	-- only this needs updated
+	isPrim _       = True
+
+coreTypeToType = primRepToType . Type.typePrimRep . CoreUtils.exprType
+
+renameForKeywords :: (NamedThing name) => name -> String
+renameForKeywords name 
+  | str `elem` keywords = "zdk" ++ str
+  | otherwise            = str
+  where
+	str = getOccString name
+
+keywords :: [String]
+keywords =
+	[ "return"
+	, "if"
+	, "then"
+	, "else"
+	, "class"
+	, "instance"
+	, "import"
+	, "throw"
+	, "try"
+	]
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Helper functions}
+%*									*
+%************************************************************************
+
+\begin{code}
+true, this,javaNull :: Expr
+this = Var thisName 
+true = Var (Name "true" (PrimType PrimBoolean))
+javaNull = Var (Name "null" objectType)
+
+vmCOLLECT :: Int -> Expr -> [Statement]
+vmCOLLECT 0 e = []
+vmCOLLECT n e = [ExprStatement 
+		    (Call varVM collectName
+			[ Literal (IntLit (toInteger n))
+			, e
+			]
+		    )
+		]
+
+vmPOP :: Type -> Expr 
+vmPOP ty = Call varVM (Name ("POP" ++ suffix ty) ty) []
+
+vmPUSH :: Expr -> Statement
+vmPUSH e = ExprStatement 
+	     (Call varVM (Name ("PUSH" ++ suffix (exprType e)) void) [e])
+
+vmRETURN :: Expr -> Statement
+vmRETURN e = Return (
+     case ty of
+	PrimType _ -> Call varVM (Name ("RETURN" ++ suffix ty)
+				       valueType
+				 ) [e]
+	_ -> e)
+  where
+	ty = exprType e
+
+var :: [Modifier] -> Name -> Expr -> Statement
+var ms field_name@(Name _ ty) value 
+   | exprType value == ty = Declaration (Field ms field_name (Just value))
+   | otherwise            = var ms field_name (Cast ty value)
+
+vmWHNF :: Expr -> Expr
+vmWHNF e = Call varVM whnfName [e]
+
+suffix :: Type -> String
+suffix (PrimType t) = primName t
+suffix _            = ""
+
+primName :: PrimType -> String
+primName PrimInt       = "int"
+primName PrimChar      = "char"
+primName PrimByte      = "byte"
+primName PrimBoolean   = "boolean"
+primName _             = error "unsupported primitive"
+
+varVM :: Expr
+varVM = Var vmName 
+
+instanceOf :: Id -> DataCon -> Expr
+instanceOf x data_con
+  = InstanceOf (Var (javaName x)) (javaConstrWkrType data_con)
+
+newCode :: [Statement] -> Expr
+newCode [Return e] = e
+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] vmName
+
+-- This is called with boolean compares, checking 
+-- to see if we can do an obvious shortcut.
+-- If there is, we return a (GOO) expression for doing this,
+
+-- So if, we have case (#< x y) of { True -> e1; False -> e2 },
+-- we will call findCmpFn with (#< x y), this return Just (Op x "<" y)
+
+findCmpPrim :: CoreExpr -> [Expr] -> Maybe Expr
+findCmpPrim (CoreSyn.App f a) as =
+     case a of
+	CoreSyn.Var v -> findCmpPrim f (javaVar v:as)
+	CoreSyn.Lit l -> findCmpPrim f (javaLit l:as)
+	_ -> Nothing
+findCmpPrim (CoreSyn.Var p)   as = 
+	case isPrimOpId_maybe p of
+	  Just prim -> find_cmp_prim prim as
+	  Nothing   -> Nothing
+findCmpPrim _                 as = Nothing
+
+find_cmp_prim cmpPrim args@[a,b] = 
+   case cmpPrim of
+     IntGtOp -> fn ">"
+     IntGeOp -> fn ">="
+     IntEqOp -> fn "=="
+     IntNeOp -> fn "/="
+     IntLtOp -> fn "<"
+     IntLeOp -> fn "<="
+     _ -> Nothing
+  where
+	fn op = Just (Op a op b)
+find_cmp_prim _ _ = Nothing
+
+findFnPrim :: CoreExpr -> [Expr] -> Maybe Expr
+findFnPrim (CoreSyn.App f a) as =
+     case a of
+	CoreSyn.Var v -> findFnPrim f (javaVar v:as)
+	CoreSyn.Lit l -> findFnPrim f (javaLit l:as)
+	_ -> Nothing
+findFnPrim (CoreSyn.Var p)   as = 
+	case isPrimOpId_maybe p of
+	  Just prim -> find_fn_prim prim as
+	  Nothing   -> Nothing
+findFnPrim _                 as = Nothing
+
+find_fn_prim cmpPrim args@[a,b] = 
+   case cmpPrim of
+     IntAddOp -> fn "+"
+     IntSubOp -> fn "-"
+     IntMulOp -> fn "*"
+     _ -> Nothing
+  where
+	fn op = Just (Op a op b)
+find_fn_prim _ _ = Nothing
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Haskell to Java Types}
+%*									*
+%************************************************************************
+
+\begin{code}
+exprType (Var (Name _ t)) = t
+exprType (Literal lit)    = litType lit
+exprType (Cast t _)       = t
+exprType (New t _ _)      = t
+exprType (Call _ (Name _ t) _) = t
+exprType (Access _ (Name _ t)) = t
+exprType (Raise t _)           = error "do not know the type of raise!"
+exprType (Op _ op _) | op `elem` ["==","/=","<","<=","=>",">"]
+		     = PrimType PrimBoolean
+exprType (Op x op _) | op `elem` ["+","-","*"]
+		     = exprType x
+exprType expr = error ("can't figure out an expression type: " ++ show expr)
+
+litType (IntLit i)    = PrimType PrimInt
+litType (CharLit i)   = PrimType PrimChar
+litType (StringLit i) = stringType	-- later, might use char array?
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Name mangling}
+%*									*
+%************************************************************************
+
+\begin{code}
+codeName, excName, thunkName :: TypeName
+codeName  = "haskell.runtime.Code"
+thunkName = "haskell.runtime.Thunk"
+excName   = "java.lang.Exception"
+
+enterName, vmName,thisName,collectName, whnfName :: Name
+enterName   = Name "ENTER"   objectType
+vmName      = Name "VM"      vmType
+thisName    = Name "this"    (Type "<this>")
+collectName = Name "COLLECT" void
+whnfName    = Name "WHNF"    objectType
+
+fieldName :: Int -> Type -> Name	-- Names for fields of a constructor
+fieldName n ty = Name ("f" ++ show n) ty
+
+withType :: Name -> Type -> Name
+withType (Name n _) t = Name n t
+
+-- This maps (local only) names Ids to Names, 
+-- using the same string as the Id.
+javaName :: Id -> Name
+javaName n 
+  | isExternalName (idName n) = error "useing javaName on global"
+  | otherwise = Name (getOccString n)
+		     (primRepToType (idPrimRep n))
+
+-- TypeName's are almost always global. This would typically return something
+-- like Test.foo or Test.Foozdc or PrelBase.foldr.
+-- Local might use locally bound types, (which do not have '.' in them).
+
+javaIdTypeName :: Id -> TypeName
+javaIdTypeName n
+    | isInternalName n' = renameForKeywords n'
+    | otherwise      = moduleString (nameModule n') ++ "." ++ renameForKeywords n'
+  where
+	     n' = getName n
+
+-- There is no such thing as a local type constructor.
+
+javaTyConTypeName :: TyCon -> TypeName
+javaTyConTypeName n = (moduleString (nameModule n') ++ "." ++ renameForKeywords 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
+
+-- The function that makes the constructor name
+-- The constructor "Foo ..." in module Test,
+-- would return the name "Test.Foo".
+
+javaConstrWkrName :: DataCon -> TypeName
+javaConstrWkrName = javaIdTypeName . dataConWorkId
+
+-- Makes x_inst for Rec decls
+-- They are *never* is primitive
+-- and always have local (type) names.
+javaInstName :: Id -> Name
+javaInstName n = Name (renameForKeywords n ++ "zdi_inst")
+		      (Type (renameForKeywords n))
+\end{code}
+
+%************************************************************************
+%*									*
+\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
+
+bytetype :: Type
+bytetype = PrimType PrimByte
+
+-- This lets you get inside a possible "Value" type,
+-- to access the internal unboxed object.
+access :: Expr -> Type -> Expr
+access expr (PrimType prim) = accessPrim (Cast valueType expr) prim
+access expr other           = expr
+
+accessPrim expr PrimInt  = Call expr (Name "intValue" inttype) []
+accessPrim expr PrimChar = Call expr (Name "charValue" chartype) []
+accessPrim expr PrimByte = Call expr (Name "byteValue" bytetype) []
+accessPrim expr other    = pprPanic "accessPrim" (text (show other))
+
+-- This is where we map from typename to types,
+-- allowing to match possible primitive types.
+mkType :: TypeName -> Type
+mkType "PrelGHC.Intzh"  = inttype
+mkType "PrelGHC.Charzh" = chartype
+mkType other            = Type other
+
+-- Turns a (global) Id into a Type (fully qualified name).
+javaIdType :: Id -> Type
+javaIdType = mkType . javaIdTypeName
+
+javaLocalIdType :: Id -> Type
+javaLocalIdType = primRepToType . idPrimRep
+
+primRepToType ::PrimRep -> Type
+primRepToType PtrRep  = objectType
+primRepToType IntRep  = inttype
+primRepToType CharRep = chartype
+primRepToType Int8Rep = bytetype
+primRepToType AddrRep = objectType
+primRepToType other   = pprPanic "primRepToType" (ppr other)
+
+-- The function that makes the constructor name
+javaConstrWkrType :: DataCon -> Type
+javaConstrWkrType con = Type (javaConstrWkrName con)
+\end{code}
+
+%************************************************************************
+%*									*
+\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 :: TypeName -> TypeName -> [Name] -> Env -> Env
+addTypeMapping origName newName frees (Env bound env)
+	= Env bound ((origName,(newName,frees)) : env)
+
+-- This a list of bound vars (with types)
+-- and a mapping from old class name 
+--     to inner class name (with a list of frees that need passed
+--	                    to the inner class.)
+
+data Env = Env Bound [(TypeName,(TypeName,[Name]))]
+
+newtype LifterM a = 
+  	LifterM { unLifterM ::
+		     TypeName ->		-- this class name
+		     Int -> 			-- uniq supply
+			  ( 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)
+	  )
+
+liftAccess :: Env -> Name -> LifterM ()
+liftAccess env@(Env bound _) name 
+	| name `elem` bound = LifterM (\ n s -> ((),[name],[],s))
+	| otherwise         = return ()
+
+scopedName :: TypeName -> LifterM a -> LifterM a
+scopedName name (LifterM m) =
+   LifterM (\ _ s -> 
+      case m name 1 of
+	(a,frees,lifted,_) -> (a,frees,lifted,s)
+      )
+
+genAnonInnerClassName :: LifterM TypeName
+genAnonInnerClassName = LifterM (\ n s ->
+	( n ++ "$" ++ show s
+	, []
+	, []
+	, s + 1
+	)
+    )
+
+genInnerClassName :: TypeName -> LifterM TypeName
+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) = 
+    Package name (concatMap liftCompilationUnit' ds)
+
+liftCompilationUnit' :: Decl -> [Decl]
+liftCompilationUnit' decl = 
+    case unLifterM (liftDecls True (Env [] []) [decl]) [] 1 of
+      (ds,_,ds',_) -> 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 n e -> 
+      do { e <- liftMaybeExpr env e
+	 ; return (Field mfs (liftName env 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 n as ts ss -> 
+      do { let newBound = getBoundAtParameters as
+	 ; (ss,_) <- liftStatements (combineEnv env newBound) ss
+	 ; return (Method mfs (liftName env n) (liftParameters env as) ts 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
+
+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 n e) ->
+      do { e <- liftMaybeExpr env e
+	 ; return ( Declaration (Field mfs (liftName env 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 { liftAccess env n 
+		 ; return (Var (liftName env 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))
+			  }	    
+   ; Raise n es -> do { es <- liftExprs env es
+		      ; return (Raise n es)
+		      }
+   ; 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 e2
+		      ; return (Op e1 o e2)
+		      }
+   ; New n es ds -> new env n es ds
+   }
+
+liftParameter env (Parameter ms n) = Parameter ms (liftName env n)
+liftParameters env = map (liftParameter env)
+
+liftName env (Name n t) = Name n (liftType env t)
+
+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 (liftNew env typ args)
+     }
+new env typ [] (Just inner) =
+  -- anon. inner class
+  do { innerName <- genAnonInnerClassName 
+     ; frees <- liftClass env innerName inner [] [unType typ]
+     ; return (New (Type (innerName)) 
+	           (map Var frees) 
+	            Nothing)
+     }
+  where unType (Type name) = name
+	unType _             = error "incorrect type style"
+new env typ _ (Just inner) = error "cant handle inner class with args"
+
+
+liftClass :: Env -> TypeName -> [Decl] -> [TypeName] -> [TypeName] -> 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 = filter (\ (Name xs _) -> xs /= "VM") (both frees bound)
+     ; let freeDefs = [ Field [Final] n Nothing | n <- trueFrees ]
+     ; let cons = mkCons innerName trueFrees
+     ; 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
+
+liftNew :: Env -> Type -> [Expr] -> Expr
+liftNew (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"
+\end{code}
diff --git a/compiler/javaGen/PrintJava.lhs b/compiler/javaGen/PrintJava.lhs
new file mode 100644
index 0000000000..eb2811d38f
--- /dev/null
+++ b/compiler/javaGen/PrintJava.lhs
@@ -0,0 +1,224 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Generate Java}
+
+\begin{code}
+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}