[project @ 2005-03-08 09:47:35 by simonpj]

Print full instances in ghci; merge

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 6fe4755..143fb6a 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -#include "Linker.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.192 2005/02/28 16:01:52 simonpj Exp $
+-- $Id: InteractiveUI.hs,v 1.193 2005/03/08 09:47:43 simonpj Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -18,7 +18,7 @@ import CompManager
 import HscTypes                ( GhciMode(..) )
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
                          IfaceConDecl(..), IfaceType,
-                         IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType,
+                         pprIfaceDeclHead, pprParendIfaceType,
                          pprIfaceForAllPart, pprIfaceType )
 import FunDeps         ( pprFundeps )
 import DriverFlags
@@ -509,7 +509,7 @@ info s  = do { let names = words s
                   vcat (intersperse (text "") (map (showThing exts) stuff)))) }
 
 showThing :: Bool -> GetInfoResult -> SDoc
-showThing exts (wanted_str, (thing, fixity, src_loc, insts)) 
+showThing exts (wanted_str, thing, fixity, src_loc, insts) 
     = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
             show_fixity fixity,
             vcat (map show_inst insts)]
@@ -520,8 +520,8 @@ showThing exts (wanted_str, (thing, fixity, src_loc, insts))
        | fix == defaultFixity = empty
        | otherwise            = ppr fix <+> text wanted_str
 
-    show_inst (iface_inst, loc)
-       = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
+    show_inst (inst_ty, loc)
+       = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
 
 showWithLoc :: SrcLoc -> SDoc -> SDoc
 showWithLoc loc doc 

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 7b3e84b..81015ac 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -28,7 +28,7 @@ import Linker         ( HValue, linkExpr )
 import TidyPgm         ( tidyCoreExpr )
 import CorePrep                ( corePrepExpr )
 import Flattening      ( flattenExpr )
-import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType ) 
+import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType ) 
 import RdrName         ( rdrNameOcc )
 import OccName         ( occNameUserString )
 import Type            ( Type )
@@ -697,8 +697,6 @@ hscParseThing parser dflags str
 
 \begin{code}
 #ifdef GHCI
-type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
-
 hscGetInfo -- like hscStmt, but deals with a single identifier
   :: HscEnv
   -> InteractiveContext                -- Context for compiling
@@ -713,14 +711,10 @@ hscGetInfo hsc_env ic str
 
        maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
 
-       let     -- str' is the the naked occurrence name
-               -- after stripping off qualification and parens (+)
-          str' = occNameUserString (rdrNameOcc rdr_name)
-
-       case maybe_tc_result of {
-            Nothing     -> return [] ;
-            Just things -> return [(str', t) | t <- things]
-       }}
+       case maybe_tc_result of
+            Nothing     -> return []
+            Just things -> return things
+       }
 #endif
 \end{code}
 

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 4a9df50..b4a0ac7 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -48,7 +48,7 @@ module TcMType (
 -- friends:
 import HsSyn           ( LHsType )
 import TypeRep         ( Type(..), PredType(..), TyNote(..),    -- Friend; can see representation
-                         Kind, ThetaType
+                         ThetaType
                        ) 
 import TcType          ( TcType, TcThetaType, TcTauType, TcPredType,
                          TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), 
@@ -56,7 +56,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          tcCmpPred, isClassPred, 
                          tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
                          tcSplitTyConApp_maybe, tcSplitForAllTys,
-                         tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
+                         tcIsTyVarTy, tcSplitSigmaTy, 
                          isUnLiftedType, isIPPred, isImmutableTyVar,
                          typeKind, isFlexi, isSkolemTyVar,
                          mkAppTy, mkTyVarTy, mkTyVarTys, 

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index b3a31f8..fd8cdae 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -7,7 +7,8 @@
 module TcRnDriver (
 #ifdef GHCI
        mkExportEnv, getModuleContents, tcRnStmt, 
-       tcRnGetInfo, tcRnExpr, tcRnType,
+       tcRnGetInfo, GetInfoResult,
+       tcRnExpr, tcRnType,
 #endif
        tcRnModule, 
        tcTopSrcDecls,
@@ -99,14 +100,15 @@ import TcType              ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
 import TcEnv           ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
 import RnTypes         ( rnLHsType )
 import Inst            ( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv         ( classInstances, instEnvElts )
+import InstEnv         ( DFunId, classInstances, instEnvElts )
 import RnExpr          ( rnStmts, rnLExpr )
 import RnNames         ( exportsToAvails )
 import LoadIface       ( loadSrcInterface, ifaceInstGates )
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), 
                          IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
                          tyThingToIfaceDecl, dfunToIfaceInst )
-import IfaceType       ( IfaceTyCon(..), interactiveExtNameFun, isLocalIfaceExtName )
+import IfaceType       ( IfaceTyCon(..), IfaceType, toIfaceType, 
+                         interactiveExtNameFun, isLocalIfaceExtName )
 import IfaceEnv                ( lookupOrig )
 import RnEnv           ( lookupOccRn, dataTcOccs, lookupFixityRn )
 import Id              ( Id, isImplicitId, setIdType, globalIdDetails )
@@ -119,6 +121,7 @@ import SrcLoc               ( interactiveSrcLoc, unLoc )
 import Kind            ( Kind )
 import Var             ( globaliseId )
 import Name            ( nameOccName )
+import OccName         ( occNameUserString )
 import NameEnv         ( delListFromNameEnv )
 import PrelNames       ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
 import HscTypes                ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
@@ -1142,12 +1145,15 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 \end{code}
 
 \begin{code}
+type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, 
+                             [(IfaceType,SrcLoc)]      -- Instances
+                    )
+
 tcRnGetInfo :: HscEnv
            -> InteractiveContext
            -> RdrName
-           -> IO (Maybe [(IfaceDecl, 
-                          Fixity, SrcLoc, 
-                          [(IfaceInst, SrcLoc)])])
+           -> IO (Maybe [GetInfoResult])
+
 -- Used to implemnent :info in GHCi
 --
 -- Look up a RdrName and return all the TyThings it might be
@@ -1189,9 +1195,17 @@ tcRnGetInfo hsc_env ictxt rdr_name
        -- their parent declaration
     let { do_one name = do { thing  <- tcLookupGlobal name
                           ; fixity <- lookupFixityRn name
-                          ; insts  <- lookupInsts ext_nm thing
-                          ; return (toIfaceDecl ext_nm thing, fixity, 
-                                    getSrcLoc thing, insts) } } ;
+                          ; dfuns  <- lookupInsts ext_nm thing
+                          ; return (str, toIfaceDecl ext_nm thing, fixity, 
+                                    getSrcLoc thing, 
+                                    [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns]
+                            ) } 
+               where
+                       -- str is the the naked occurrence name
+                       -- after stripping off qualification and parens (+)
+                 str = occNameUserString (nameOccName name)
+       } ;
+
                -- For the SrcLoc, the 'thing' has better info than
                -- the 'name' because getting the former forced the
                -- declaration to be loaded into the cache
@@ -1200,20 +1214,20 @@ tcRnGetInfo hsc_env ictxt rdr_name
     return (fst (removeDups cmp results))
     }
   where
-    cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
+    cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
     ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
 
 
-lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId]
 -- Filter the instances by the ones whose tycons (or clases resp) 
 -- are in scope unqualified.  Otherwise we list a whole lot too many!
 lookupInsts ext_nm (AClass cls)
   = do { loadImportedInsts cls []      -- [] means load all instances for cls
        ; inst_envs <- tcGetInstEnvs
-       ; return [ (inst, getSrcLoc dfun)
+       ; return [ dfun
                 | (_,_,dfun) <- classInstances inst_envs cls
-                , let inst = dfunToIfaceInst ext_nm dfun
-                      (_, tycons) = ifaceInstGates (ifInstHead inst)
+                , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
+                       -- Rather an indirect/inefficient test, but there we go
                 , all print_tycon_unqual tycons ] }
   where
     print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
@@ -1227,11 +1241,10 @@ lookupInsts ext_nm (ATyCon tc)
        ; mapM_ (\c -> loadImportedInsts c [])
                (typeEnvClasses (eps_PTE eps))
        ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
-       ; return [ (inst, getSrcLoc dfun)
+       ; return [ dfun
                 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
                 , relevant dfun
-                , let inst     = dfunToIfaceInst ext_nm dfun
-                      (cls, _) = ifaceInstGates (ifInstHead inst)
+                , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
                 , isLocalIfaceExtName cls ]  }
   where
     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)