From 1965e001f7e023563c1d8925c4f75f63989a8720 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Thu, 16 Aug 2001 10:54:22 +0000
Subject: [PATCH] [project @ 2001-08-16 10:54:22 by simonmar] Include fixity
 info in the output from :info.

---
 ghc/compiler/compMan/CompManager.lhs |   20 +++++++++++++++++---
 ghc/compiler/ghci/InteractiveUI.hs   |   19 +++++++++++++------
 2 files changed, 30 insertions(+), 9 deletions(-)

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index e87f074..98c6b65 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -49,7 +49,8 @@ import HscMain		( initPersistentCompilerState )
 import HscTypes
 import RnEnv		( unQualInScope )
 import Id		( idType, idName )
-import Name		( Name, NamedThing(..), nameRdrName )
+import Name		( Name, NamedThing(..), nameRdrName, nameModule,
+			  isHomePackageName )
 import NameEnv
 import RdrName		( lookupRdrEnv, emptyRdrEnv )
 import Module
@@ -63,8 +64,10 @@ import ErrUtils		( showPass )
 import SysTools		( cleanTempFilesExcept )
 import Util
 import Outputable
+import BasicTypes	( Fixity, defaultFixity )
 import Panic
 import CmdLineOpts	( DynFlags(..) )
+
 import IOExts
 
 #ifdef GHCI
@@ -180,13 +183,24 @@ moduleNameToModule mn
 
 #ifdef GHCI
 cmInfoThing :: CmState -> DynFlags -> String 
-	-> IO (CmState, PrintUnqualified, [TyThing])
+	-> IO (CmState, PrintUnqualified, [(TyThing,Fixity)])
 cmInfoThing cmstate dflags id
    = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
-	return (cmstate{ pcs=new_pcs }, unqual, things)
+	let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things
+	return (cmstate{ pcs=new_pcs }, unqual, pairs)
    where 
      CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
      unqual = getUnqual pcs hit icontext
+
+     getFixity :: PersistentCompilerState -> Name -> Fixity
+     getFixity pcs name
+	| Just iface  <- lookupModuleEnv iface_table (nameModule name),
+	  Just fixity <- lookupNameEnv (mi_fixities iface) name
+	  = fixity
+	| otherwise
+	  = defaultFixity
+	where iface_table | isHomePackageName name = hit
+			  | otherwise              = pcs_PIT pcs
 #endif
 
 -----------------------------------------------------------------------------
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 31cae90..af0faad 100644
--- 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.90 2001/08/16 10:54:22 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -31,7 +31,8 @@ import Class		( className )
 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(..) )
@@ -387,14 +388,20 @@ 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)]
-- 
1.7.10.4