[project @ 2001-08-16 10:54:22 by simonmar]

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

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 9d6f6a1..af0faad 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.87 2001/08/15 14:41:49 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.90 2001/08/16 10:54:22 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -25,11 +25,14 @@ import DriverUtil
 import Linker
 import Finder          ( flushPackageCache )
 import Util
-import Id              ( isDataConWrapId, idName )
+import Id              ( isRecordSelector, recordSelectorFieldLabel, 
+                         isDataConWrapId, idName )
 import Class           ( className )
-import TyCon           ( tyConName )
+import TyCon           ( tyConName, tyConClass_maybe )
+import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
-import Name            ( Name, isHomePackageName, nameSrcLoc )
+import Name            ( Name, isHomePackageName, nameSrcLoc, NamedThing(..) )
+import BasicTypes      ( defaultFixity )
 import Outputable
 import CmdLineOpts     ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
 import Panic           ( GhcException(..) )
@@ -385,24 +388,36 @@ 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) ]
+
+    showFixity fix name
+       | fix == defaultFixity = empty
+       | otherwise            = ppr fix <+> ppr name
 
     showTyThing (AClass cl) 
        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
     showTyThing (ATyCon ty)
        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
     showTyThing (AnId   id)
-       | isDataConWrapId id 
-       = hcat [ppr id, text " is a data constructor", showSrcLoc (idName id)]
-       | otherwise
-       = hcat [ppr id, text " is a variable", showSrcLoc (idName id)]
+       = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
+
+    idDescr id
+       | isRecordSelector id = 
+               case tyConClass_maybe (fieldLabelTyCon (
+                               recordSelectorFieldLabel id)) of
+                       Nothing -> text "record selector"
+                       Just c  -> text "method in class " <> ppr c
+       | isDataConWrapId id  = text "data constructor"
+       | otherwise           = text "variable"
 
        -- also print out the source location for home things
     showSrcLoc name