Commit d2d71b0e authored by ian@well-typed.com's avatar ian@well-typed.com

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

parents ecc1882e ca39e777
......@@ -182,6 +182,8 @@ module GHC (
pprInstance, pprInstanceHdr,
pprFamInst,
FamInst, Branched,
-- ** Types and Kinds
Type, splitForAllTys, funResultTy,
pprParendType, pprTypeApp,
......
......@@ -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
......
......@@ -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!
......
......@@ -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
......
......@@ -76,7 +76,7 @@ module TcType (
-- Misc type manipulators
deNoteType, occurCheckExpand, OccCheckResult(..),
orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
orphNamesOfCoCon,
orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey,
evVarPred_maybe, evVarPred,
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment