[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 ea3431c..af0faad 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.85 2001/08/13 15:49:37 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.90 2001/08/16 10:54:22 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -16,7 +16,7 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 
 import Packages
 import CompManager
-import HscTypes                ( GhciMode(..) )
+import HscTypes                ( GhciMode(..), TyThing(..) )
 import MkIface          ( ifaceTyCls )
 import ByteCodeLink
 import DriverFlags
@@ -25,7 +25,14 @@ import DriverUtil
 import Linker
 import Finder          ( flushPackageCache )
 import Util
-import Name            ( Name )
+import Id              ( isRecordSelector, recordSelectorFieldLabel, 
+                         isDataConWrapId, idName )
+import Class           ( className )
+import TyCon           ( tyConName, tyConClass_maybe )
+import FieldLabel      ( fieldLabelTyCon )
+import SrcLoc          ( isGoodSrcLoc )
+import Name            ( Name, isHomePackageName, nameSrcLoc, NamedThing(..) )
+import BasicTypes      ( defaultFixity )
 import Outputable
 import CmdLineOpts     ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
 import Panic           ( GhcException(..) )
@@ -97,8 +104,7 @@ helpText = "\
 \   :cd <dir>             change directory to <dir>\n\ 
 \   :def <cmd> <expr>      define a command :<cmd>\n\ 
 \   :help, :?             display this list of commands\n\ 
-\   :info [<name> ...]     display information about the given names, or\n\ 
-\                          about currently loaded files if no names given\n\ 
+\   :info [<name> ...]     display information about the given names\n\ 
 \   :load <filename> ...   load module(s) and their dependents\n\ 
 \   :module <mod>         set the context for expression evaluation to <mod>\n\ 
 \   :reload               reload the current module set\n\ 
@@ -377,14 +383,54 @@ info :: String -> GHCi ()
 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 info s = do
   let names = words s
-  st <- getGHCiState
-  let cmst = cmstate st
+  state <- getGHCiState
   dflags <- io getDynFlags
-  things <- io (mapM (cmInfoThing cmst dflags) names)
-  let real_things = [ x | Just x <- things ]
-  let descs = map (`ifaceTyCls` []) real_things
-  let strings = map (showSDoc . ppr) descs
-  io (mapM_ putStr strings)
+  let 
+    infoThings cms [] = return cms
+    infoThings cms (name:names) = do
+      (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
+      io (putStrLn (showSDocForUser unqual (
+           vcat (intersperse (text "") (map showThing stuff))))
+         )
+      infoThings cms names
+
+    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)
+       = 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
+       | isHomePackageName name && isGoodSrcLoc loc
+       = hsep [ text ", defined at", ppr loc ]
+       | otherwise
+       = empty
+       where loc = nameSrcLoc name
+
+  cms <- infoThings (cmstate state) names
+  setGHCiState state{ cmstate = cms }
+  return ()
+
 
 addModule :: String -> GHCi ()
 addModule str = do