[project @ 2001-10-01 13:28:40 by rrt]

[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 31cae90..e291d6f 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.89 2001/08/15 15:50:41 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.91 2001/08/20 16:17:17 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -28,10 +28,13 @@ import Util
 import Id              ( isRecordSelector, recordSelectorFieldLabel, 
                          isDataConWrapId, idName )
 import Class           ( className )
-import TyCon           ( tyConName, tyConClass_maybe )
+import TyCon           ( tyConName, tyConClass_maybe, isPrimTyCon )
 import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
-import Name            ( Name, isHomePackageName, nameSrcLoc )
+import Name            ( Name, isHomePackageName, nameSrcLoc, nameOccName,
+                         NamedThing(..) )
+import OccName         ( isSymOcc )
+import BasicTypes      ( defaultFixity )
 import Outputable
 import CmdLineOpts     ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
 import Panic           ( GhcException(..) )
@@ -387,18 +390,30 @@ info s = do
   let 
     infoThings cms [] = return cms
     infoThings cms (name:names) = do
-      (cms, unqual, ty_things) <- io (cmInfoThing cms dflags name)
+      (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
       io (putStrLn (showSDocForUser unqual (
-           vcat (intersperse (text "") (map showThing ty_things))))
+           vcat (intersperse (text "") (map showThing stuff))))
          )
       infoThings cms names
 
-    showThing ty_thing = vcat [ text "-- " <> showTyThing ty_thing, 
-                               ppr (ifaceTyCls ty_thing) ]
+    showThing (ty_thing, fixity) 
+       = vcat [ text "-- " <> showTyThing ty_thing, 
+                showFixity fixity (getName ty_thing),
+                ppr (ifaceTyCls ty_thing) ]
 
-    showTyThing (AClass cl) 
+    showFixity fix name
+       | fix == defaultFixity = empty
+       | otherwise            = ppr fix <+> 
+                                (if isSymOcc (nameOccName name)
+                                       then ppr name
+                                       else char '`' <> ppr name <> char '`')
+
+    showTyThing (AClass cl)
        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
     showTyThing (ATyCon ty)
+       | isPrimTyCon ty
+       = hcat [ppr ty, text " is a primitive type constructor"]
+       | otherwise
        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
     showTyThing (AnId   id)
        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]