summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/main/HscMain.hs2
-rw-r--r--compiler/main/InteractiveEval.hs16
-rw-r--r--compiler/typecheck/TcRnDriver.lhs33
-rw-r--r--compiler/typecheck/TcType.lhs2
-rw-r--r--compiler/types/FamInstEnv.lhs14
-rw-r--r--compiler/types/InstEnv.lhs13
-rw-r--r--ghc/InteractiveUI.hs16
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
View Lorry Controller Status