[project @ 2005-02-25 13:06:31 by simonpj]

[ghc-hetmet.git] / ghc / compiler / iface / IfaceType.lhs

diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs
index bb51778..b713908 100644 (file)
--- a/ghc/compiler/iface/IfaceType.lhs
+++ b/ghc/compiler/iface/IfaceType.lhs
@@ -9,7 +9,8 @@ module IfaceType (
        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
 
-       IfaceExtName(..), mkIfaceExtName, ifaceTyConName, 
+       IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
+       ifaceTyConName, interactiveExtNameFun,
 
        -- Conversion from Type -> IfaceType
        toIfaceType, toIfacePred, toIfaceContext, 
@@ -25,11 +26,11 @@ module IfaceType (
 #include "HsVersions.h"
 
 import Kind            ( Kind(..) )
-import TypeRep         ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
+import TypeRep         ( Type(..), TyNote(..), PredType(..), ThetaType )
 import TyCon           ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
 import Var             ( isId, tyVarKind, idType )
 import TysWiredIn      ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
-import OccName         ( OccName )
+import OccName         ( OccName, parenSymOcc )
 import Name            ( Name, getName, getOccName, nameModule, nameOccName )
 import Module          ( Module )
 import BasicTypes      ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
@@ -51,7 +52,8 @@ data IfaceExtName
                                        -- of whether they are home-pkg or not
 
   | HomePkg Module OccName Version     -- From another module in home package;
-                                       -- has version #
+                                       -- has version #; in all other respects,
+                                       -- HomePkg and ExtPkg are the same
 
   | LocalTop OccName                   -- Top-level from the same module as 
                                        -- the enclosing IfaceDecl
@@ -62,8 +64,27 @@ data IfaceExtName
        -- LocalTopSub is written into iface files as LocalTop; the parent 
        -- info is only used when computing version information in MkIface
 
+isLocalIfaceExtName :: IfaceExtName -> Bool
+isLocalIfaceExtName (LocalTop _)      = True
+isLocalIfaceExtName (LocalTopSub _ _) = True
+isLocalIfaceExtName other            = False
+
 mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
        -- Local helper for wired-in names
+
+ifaceExtOcc :: IfaceExtName -> OccName
+ifaceExtOcc (ExtPkg _ occ)     = occ
+ifaceExtOcc (HomePkg _ occ _)  = occ
+ifaceExtOcc (LocalTop occ)     = occ
+ifaceExtOcc (LocalTopSub occ _) = occ
+
+interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
+interactiveExtNameFun print_unqual name
+  | print_unqual mod occ = LocalTop occ
+  | otherwise           = ExtPkg mod occ
+  where
+    mod = nameModule name
+    occ = nameOccName name
 \end{code}
 
 
@@ -183,12 +204,9 @@ instance Outputable IfaceExtName where
     ppr (LocalTopSub occ _)    = ppr occ       -- from an ordinary occurrence?
 
 pprExt :: Module -> OccName -> SDoc
-pprExt mod occ
-  = getPprStyle $ \ sty ->
-    if unqualStyle sty mod occ then
-       ppr occ
-    else 
-       ppr mod <> dot <> ppr occ
+-- No need to worry about printing unqualified becuase that was handled
+-- in the transiation to IfaceSyn 
+pprExt mod occ = ppr mod <> dot <> ppr occ
 
 instance Outputable IfaceBndr where
     ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
@@ -260,7 +278,7 @@ pprIfaceForAllPart tvs ctxt doc
            | otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot
 
 -------------------
-ppr_tc_app ctxt_prec tc         []   = ppr tc
+ppr_tc_app ctxt_prec tc         []   = ppr_tc tc
 ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets   (pprIfaceType ty)
 ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
 ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
@@ -268,13 +286,19 @@ ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
   = tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
 ppr_tc_app ctxt_prec tc tys 
   = maybeParen ctxt_prec tYCON_PREC 
-              (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+              (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
+
+ppr_tc :: IfaceTyCon -> SDoc
+-- Wrap infix type constructors in parens
+ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (ifaceExtOcc ext_nm) (ppr tc)
+ppr_tc tc                 = ppr tc
 
 -------------------
 instance Outputable IfacePredType where
        -- Print without parens
   ppr (IfaceIParam ip ty)  = hsep [ppr ip, dcolon, ppr ty]
-  ppr (IfaceClassP cls ts) = ppr cls <+> sep (map pprParendIfaceType ts)
+  ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (ppr cls)
+                            <+> sep (map pprParendIfaceType ts)
 
 instance Outputable IfaceTyCon where
   ppr (IfaceTc ext) = ppr ext