Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

8 files changed, 72 insertions, 26 deletions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 4aa0495151..c72f1f1be6 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -182,6 +182,8 @@ module GHC (
         pprInstance, pprInstanceHdr,
         pprFamInst,
 
+        FamInst, Branched,
+
         -- ** Types and Kinds
         Type, splitForAllTys, funResultTy, 
         pprParendType, pprTypeApp, 
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 90a42fb18e..c97e3ec724 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -303,7 +303,7 @@ hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
       -- "name not found", and the Maybe in the return type
       -- is used to indicate that.
 
-hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst]))
+hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst Branched]))
 hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
   ioMsgMaybe' $ tcRnGetInfo hsc_env name
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 1d74c63a3b..d0c1305355 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -43,6 +43,7 @@ import HscMain
 import HsSyn
 import HscTypes
 import InstEnv
+import FamInstEnv ( FamInst, Branched, orphNamesOfFamInst )
 import TyCon
 import Type     hiding( typeKind )
 import TcType           hiding( typeKind )
@@ -925,20 +926,25 @@ moduleIsInterpreted modl = withSession $ \h ->
 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 --      (see Trac #1581)
-getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
+getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst Branched]))
 getInfo allInfo name
   = withSession $ \hsc_env ->
     do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
        case mb_stuff of
          Nothing -> return Nothing
-         Just (thing, fixity, ispecs) -> do
+         Just (thing, fixity, cls_insts, fam_insts) -> do
            let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
-           return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
+
+           -- Filter the instances based on whether the constituent names of their
+           -- instance heads are all in scope.
+           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
+               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
+           return (Just (thing, fixity, cls_insts', fam_insts'))
   where
-    plausible rdr_env ispec
+    plausible rdr_env names
           -- Dfun involving only names that are in ic_rn_glb_env
         = allInfo
-       || all ok (nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec)
+       || all ok (nameSetToList names)
         where   -- A name is ok if it's in the rdr_env,
                 -- whether qualified or not
           ok n | n == name         = True       -- The one we looked for in the first place!
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 5b7eb739b4..275ce07089 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -76,7 +76,6 @@ import DataCon
 import Type
 import Class
 import CoAxiom  ( CoAxBranch(..) )
-import TcType   ( orphNamesOfDFunHead )
 import Inst     ( tcGetInstEnvs )
 import Data.List ( sortBy )
 import Data.IORef ( readIORef )
@@ -1735,7 +1734,7 @@ tcRnLookupName' name = do
 
 tcRnGetInfo :: HscEnv
             -> Name
-            -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst]))
+            -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst Branched]))
 
 -- Used to implement :info in GHCi
 --
@@ -1757,29 +1756,41 @@ tcRnGetInfo hsc_env name
 
     thing  <- tcRnLookupName' name
     fixity <- lookupFixityRn name
-    ispecs <- lookupInsts thing
-    return (thing, fixity, ispecs)
+    (cls_insts, fam_insts) <- lookupInsts thing
+    return (thing, fixity, cls_insts, fam_insts)
 
-lookupInsts :: TyThing -> TcM [ClsInst]
+lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst Branched])
 lookupInsts (ATyCon tc)
   | Just cls <- tyConClass_maybe tc
   = do  { inst_envs <- tcGetInstEnvs
-        ; return (classInstances inst_envs cls) }
+        ; return (classInstances inst_envs cls, []) }
+
+  | isFamilyTyCon tc || isTyConAssoc tc
+  = do  { inst_envs <- tcGetFamInstEnvs
+        ; return ([], familyInstances inst_envs tc) }
 
   | otherwise
   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
+        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
                 -- Load all instances for all classes that are
                 -- in the type environment (which are all the ones
                 -- we've seen in any interface file so far)
-        ; return [ ispec        -- Search all
+
+          -- Return only the instances relevant to the given thing, i.e.
+          -- the instances whose head contains the thing's name.
+        ; let cls_insts =
+                 [ ispec        -- Search all
                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
-                 , let dfun = instanceDFunId ispec
-                 , relevant dfun ] }
+                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
+        ; let fam_insts =
+                 [ fispec
+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
+        ; return (cls_insts, fam_insts) }
   where
-    relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
     tc_name     = tyConName tc
 
-lookupInsts _ = return []
+lookupInsts _ = return ([],[])
 
 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
 -- Load the interface for everything that is in scope unqualified
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 7a69b4b250..77f7de682f 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -76,7 +76,7 @@ module TcType (
   -- Misc type manipulators
   deNoteType, occurCheckExpand, OccCheckResult(..),
   orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
-  orphNamesOfCoCon,
+  orphNamesOfTypes, orphNamesOfCoCon,
   getDFunTyKey,
   evVarPred_maybe, evVarPred,
 
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 0efd3ca75b..4e9b27e6b9 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -22,7 +22,7 @@ module FamInstEnv (
         FamInstEnv, FamInstEnvs,
         emptyFamInstEnvs, emptyFamInstEnv, famInstEnvElts, familyInstances,
         extendFamInstEnvList, extendFamInstEnv, deleteFromFamInstEnv,
-        identicalFamInst,
+        identicalFamInst, orphNamesOfFamInst,
 
         FamInstMatch(..),
         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts',
@@ -35,6 +35,7 @@ module FamInstEnv (
 
 #include "HsVersions.h"
 
+import TcType ( orphNamesOfTypes )
 import InstEnv
 import Unify
 import Type
@@ -367,6 +368,17 @@ familyInstances (pkg_fie, home_fie) fam
                 Just (FamIE insts) -> insts
                 Nothing            -> []
 
+-- | Collects the names of the concrete types and type constructors that
+-- make up the LHS of a type family instance. For instance,
+-- given `type family Foo a b`:
+--
+-- `type instance Foo (F (G (H a))) b = ...` would yield [F,G,H]
+--
+-- Used in the implementation of ":info" in GHCi.
+orphNamesOfFamInst :: FamInst Branched -> NameSet
+orphNamesOfFamInst
+    = orphNamesOfTypes . concat . brListMap cab_lhs . coAxiomBranches . fi_axiom
+
 extendFamInstEnvList :: FamInstEnv -> [FamInst br] -> FamInstEnv
 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
 
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 569697caa2..18d67d8053 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -15,7 +15,7 @@ module InstEnv (
 
         InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, 
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
-        classInstances, instanceBindFun,
+        classInstances, orphNamesOfClsInst, instanceBindFun,
         instanceCantMatch, roughMatchTcs
     ) where
 
@@ -25,6 +25,7 @@ import Class
 import Var
 import VarSet
 import Name
+import NameSet
 import TcType
 import TyCon
 import Unify
@@ -399,6 +400,16 @@ classInstances (pkg_ie, home_ie) cls
                 Just (ClsIE insts) -> insts
                 Nothing            -> []
 
+-- | Collects the names of concrete types and type constructors that make
+-- up the head of a class instance. For instance, given `class Foo a b`:
+--
+-- `instance Foo (Either (Maybe Int) a) Bool` would yield
+--      [Either, Maybe, Int, Bool]
+--
+-- Used in the implementation of ":info" in GHCi.
+orphNamesOfClsInst :: ClsInst -> NameSet
+orphNamesOfClsInst = orphNamesOfDFunHead . idType . instanceDFunId
+
 extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
 extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
 
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 5b3e572650..263babeafc 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1022,7 +1022,7 @@ infoThing allInfo str = do
     let pefas = gopt Opt_PrintExplicitForalls dflags
     names     <- GHC.parseName str
     mb_stuffs <- mapM (GHC.getInfo allInfo) names
-    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
+    let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)
     return $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered)
 
   -- Filter out names whose parent is also there Good
@@ -1037,11 +1037,13 @@ filterOutChildren get_thing xs
                      Just p  -> getName p `elemNameSet` all_names
                      Nothing -> False
 
-pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
-pprInfo pefas (thing, fixity, insts)
+pprInfo :: PrintExplicitForalls
+        -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc
+pprInfo pefas (thing, fixity, cls_insts, fam_insts)
   =  pprTyThingInContextLoc pefas thing
   $$ show_fixity
-  $$ vcat (map GHC.pprInstance insts)
+  $$ vcat (map GHC.pprInstance cls_insts)
+  $$ vcat (map GHC.pprFamInst  fam_insts)
   where
     show_fixity
         | fixity == GHC.defaultFixity = empty
@@ -2191,8 +2193,10 @@ showBindings = do
         let pefas = gopt Opt_PrintExplicitForalls dflags
         mb_stuff <- GHC.getInfo False (getName tt)
         return $ maybe (text "") (pprTT pefas) mb_stuff
-    pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
-    pprTT pefas (thing, fixity, _insts) =
+
+    pprTT :: PrintExplicitForalls
+          -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc
+    pprTT pefas (thing, fixity, _cls_insts, _fam_insts) =
         pprTyThing pefas thing
         $$ show_fixity
       where