[project @ 2001-08-29 15:12:21 by sewardj]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsDecls.lhs

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index fc136d3..04b2af1 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -26,14 +26,14 @@ module HsDecls (
 -- friends:
 import HsBinds         ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
 import HsExpr          ( HsExpr )
+import HsImpExp                ( ppr_var )
 import HsTypes
 import PprCore         ( pprCoreRule )
 import HsCore          ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
                          eq_ufBinders, eq_ufExpr, pprUfExpr 
                        )
 import CoreSyn         ( CoreRule(..) )
-import BasicTypes      ( NewOrData(..) )
-import Demand          ( StrictnessMark(..) )
+import BasicTypes      ( NewOrData(..), StrictnessMark(..) )
 import ForeignCall     ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
 
 -- others:
@@ -42,7 +42,11 @@ import FunDeps               ( pprFundeps )
 import Class           ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString )
 import Outputable      
+import Util            ( eqListBy )
 import SrcLoc          ( SrcLoc )
+import FastString
+
+import Maybe           ( isNothing, fromJust ) 
 \end{code}
 
 
@@ -261,9 +265,10 @@ data TyClDecl name pat
                tcdLoc :: SrcLoc
     }
 
-  | ForeignType { tcdName   :: name,           -- See remarks about IfaceSig above
-                 tcdFoType :: FoType,
-                 tcdLoc    :: SrcLoc }
+  | ForeignType { tcdName    :: name,          -- See remarks about IfaceSig above
+                 tcdExtName :: Maybe FastString,
+                 tcdFoType  :: FoType,
+                 tcdLoc     :: SrcLoc }
 
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: HsContext name,     -- context
@@ -452,7 +457,10 @@ instance (NamedThing name, Outputable name, Outputable pat)
              => Outputable (TyClDecl name pat) where
 
     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
-       = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+       = getPprStyle $ \ sty ->
+          hsep [ if ifaceStyle sty then ppr var else ppr_var var,
+                 dcolon, ppr ty, pprHsIdInfo info
+               ]
 
     ppr (ForeignType {tcdName = tycon})
        = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
@@ -464,7 +472,7 @@ instance (NamedThing name, Outputable name, Outputable pat)
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
                 tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
                 tcdDerivs = derivings})
-      = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
+      = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
                  (pp_condecls condecls ncons)
                  derivings
       where
@@ -483,14 +491,17 @@ instance (NamedThing name, Outputable name, Outputable pat)
       where
         top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
        ppr_sig sig = ppr sig <> semi
+
        pp_methods = getPprStyle $ \ sty ->
-                    if ifaceStyle sty then empty else ppr methods
+                    if ifaceStyle sty || isNothing methods
+                       then empty
+                       else ppr (fromJust methods)
         
 pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
 pp_condecls []     ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
-pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
+pp_condecls (c:cs) ncons = equals <+> sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
 
 pp_tydecl pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [
@@ -600,11 +611,17 @@ instance (Outputable name) => Outputable (ConDecl name) where
 ppr_con_details con (InfixCon ty1 ty2)
   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 
+-- ConDecls generated by MkIface.ifaceTyCls always have a VanillaCon, even
+-- if the constructor is an infix one.  This is because in an interface file
+-- we don't distinguish between the two.  Hence when printing these for the
+-- user, we need to parenthesise infix constructor names.
 ppr_con_details con (VanillaCon tys)
-  = ppr con <+> hsep (map (ppr_bang) tys)
+  = getPprStyle $ \ sty ->
+    hsep ((if ifaceStyle sty then ppr con else ppr_var con)
+         : map (ppr_bang) tys)
 
 ppr_con_details con (RecCon fields)
-  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
+  = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
   where
     ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
                         dcolon <+>