X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=94daff05effce3077a785d7a584f21618c4dd3d7;hp=2146932b2431a14607a43ccf3315da1147df5aad;hb=HEAD;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 2146932..94daff0 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -17,7 +17,8 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupFamInst, + tcLookupLocatedClass, + tcLookupFamInst, tcLookupDataFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, @@ -26,19 +27,23 @@ module TcEnv( tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, - lclEnvElts, getInLocalScope, findGlobals, + getInLocalScope, wrongThingErr, pprBinders, + getHetMetLevel, tcExtendRecEnv, -- For knot-tying -- Rules tcExtendRules, + -- Defaults + tcGetDefaultTys, + -- Global type variables tcGetGlobalTyVars, -- Template Haskell stuff - checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, + checkWellStaged, tcMetaTy, thLevel, topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids @@ -49,18 +54,19 @@ module TcEnv( #include "HsVersions.h" import HsSyn -import TcIface import IfaceEnv import TcRnMonad import TcMType import TcType --- import TcSuspension -import qualified Type +import TcIface +import PrelNames +import TysWiredIn +-- import qualified Type import Id import Coercion import Var import VarSet -import VarEnv +-- import VarEnv import RdrName import InstEnv import FamInstEnv @@ -71,6 +77,7 @@ import Class import Name import NameEnv import HscTypes +import DynFlags import SrcLoc import Outputable import Unique @@ -115,10 +122,10 @@ tcLookupGlobal name -- Should it have been in the local envt? { case nameModule_maybe name of - Nothing -> notFound name env -- Internal names can happen in GHCi + Nothing -> notFound name -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name env -- should be in tcg_type_env + -> notFound name -- should be in tcg_type_env | otherwise -> tcImportDecl name -- Go find it in an interface }}}}} @@ -171,9 +178,13 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Look up the instance tycon of a family instance. -- --- The match must be unique - ie, match exactly one instance - but the --- type arguments used for matching may be more specific than those of --- the family instance declaration. +-- The match may be ambiguous (as we know that overlapping instances have +-- identical right-hand sides under overlapping substitutions - see +-- 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used +-- for matching must be equal to or be more specific than those of the family +-- instance declaration. We pick one of the matches in case of ambiguity; as +-- the right-hand sides are identical under the match substitution, the choice +-- does not matter. -- -- Return the instance tycon and its type instance. For example, if we have -- @@ -187,19 +198,62 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon -- tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type])) tcLookupFamInst tycon tys - | not (isOpenTyCon tycon) + | not (isFamilyTyCon tycon) = return Nothing | otherwise = do { env <- getGblEnv ; eps <- getEps ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv) ; case lookupFamInstEnv instEnv tycon tys of - [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst, - rep_tys) - _ -> return Nothing + [] -> return Nothing + ((fam_inst, rep_tys):_) + -> return $ Just (famInstTyCon fam_inst, rep_tys) } + +tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) +-- Find the instance of a data family +-- Note [Looking up family instances for deriving] +tcLookupDataFamInst tycon tys + | not (isFamilyTyCon tycon) + = return (tycon, tys) + | otherwise + = ASSERT( isAlgTyCon tycon ) + do { maybeFamInst <- tcLookupFamInst tycon tys + ; case maybeFamInst of + Nothing -> famInstNotFound tycon tys + Just famInst -> return famInst } + +famInstNotFound :: TyCon -> [Type] -> TcM a +famInstNotFound tycon tys + = failWithTc (ptext (sLit "No family instance for") + <+> quotes (pprTypeApp tycon tys)) \end{code} +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declrations. + \begin{code} instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where lookupThing = tcLookupGlobal @@ -259,8 +313,8 @@ tcLookupLocated = addLocM tcLookup tcLookup :: Name -> TcM TcTyThing tcLookup name = do - local_env <- getLclEnv - case lookupNameEnv (tcl_env local_env) name of + local_env <- getLclTypeEnv + case lookupNameEnv local_env name of Just thing -> return thing Nothing -> AGlobal <$> tcLookupGlobal name @@ -296,15 +350,10 @@ tcLookupLocalIds ns = do -> ASSERT( lvl == lvl1 ) id _ -> pprPanic "tcLookupLocalIds" (ppr name) -lclEnvElts :: TcLclEnv -> [TcTyThing] -lclEnvElts env = nameEnvElts (tcl_env env) - getInLocalScope :: TcM (Name -> Bool) -- Ids only -getInLocalScope = do - env <- getLclEnv - let lcl_env = tcl_env env - return (`elemNameEnv` lcl_env) +getInLocalScope = do { lcl_env <- getLclTypeEnv + ; return (`elemNameEnv` lcl_env) } \end{code} \begin{code} @@ -315,13 +364,10 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r +tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r tcExtendKindEnvTvs bndrs thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env pairs - pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs] + = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) + (thing_inside bndrs) tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside @@ -333,7 +379,7 @@ tcExtendTyVarEnv2 binds thing_inside = do tcl_tyvars = gtvs, tcl_rdr = rdr_env}) <- getLclEnv let - rdr_env' = extendLocalRdrEnv rdr_env (map fst binds) + rdr_env' = extendLocalRdrEnvList rdr_env (map fst binds) new_tv_set = tcTyVarsOfTypes (map snd binds) le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds] @@ -343,7 +389,7 @@ tcExtendTyVarEnv2 binds thing_inside = do -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. - gtvs' <- tc_extend_gtvs gtvs new_tv_set + gtvs' <- tcExtendGlobalTyVars gtvs new_tv_set setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside getScopedTyVarBinds :: TcM [(Name, TcType)] @@ -360,11 +406,19 @@ tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] th tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside +getHetMetLevel :: TcM [TyVar] +getHetMetLevel = + do { env <- getEnv + ; return $ case env of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x + } + tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside = do { env <- getLclEnv - ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside } + ; hetMetLevel <- getHetMetLevel + ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) hetMetLevel names_w_ids thing_inside } + tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction @@ -373,11 +427,13 @@ tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- GHCi has already compiled it to bytecode tcExtendGhciEnv ids thing_inside = do { env <- getLclEnv - ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside } + ; hetMetLevel <- getHetMetLevel + ; tc_extend_local_id_env env impLevel hetMetLevel [(idName id, id) | id <- ids] thing_inside } tc_extend_local_id_env -- This is the guy who does the work :: TcLclEnv -> ThLevel + -> [TyVar] -> [(Name,TcId)] -> TcM a -> TcM a -- Invariant: the TcIds are fully zonked. Reasons: @@ -387,111 +443,25 @@ tc_extend_local_id_env -- This is the guy who does the work -- in the types, because instantiation does not look through such things -- (c) The call to tyVarsOfTypes is ok without looking through refs -tc_extend_local_id_env env th_lvl names_w_ids thing_inside - = do { traceTc (text "env2") - ; traceTc (text "env3" <+> ppr extra_env) - ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars +tc_extend_local_id_env env th_lvl hetMetLevel names_w_ids thing_inside + = do { traceTc "env2" (ppr extra_env) + ; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'} ; setLclEnv env' thing_inside } where extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] extra_env = [ (name, ATcId { tct_id = id, tct_level = th_lvl, - tct_type = id_ty, - tct_co = case isRefineableTy id_ty of - (True,_) -> Unrefineable - (_,True) -> Rigid idHsWrapper - _ -> Wobbly}) - | (name,id) <- names_w_ids, let id_ty = idType id] + tct_hetMetLevel = hetMetLevel + }) + | (name,id) <- names_w_ids] le' = extendNameEnvList (tcl_env env) extra_env - rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids] -\end{code} - - -\begin{code} ------------------------ --- findGlobals looks at the value environment and finds values --- whose types mention the offending type variable. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. - -findGlobals :: TcTyVarSet - -> TidyEnv - -> TcM (TidyEnv, [SDoc]) - -findGlobals tvs tidy_env = do - lcl_env <- getLclEnv - go tidy_env [] (lclEnvElts lcl_env) - where - go tidy_env acc [] = return (tidy_env, acc) - go tidy_env acc (thing : things) = do - (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing - case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things - - ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty - ------------------------ -find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing - -> TcM (TidyEnv, Maybe SDoc) -find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do - id_ty <- zonkTcType (idType id) - if ignore_it id_ty then - return (tidy_env, Nothing) - else let - (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty - msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, - nest 2 (parens (ptext (sLit "bound at") <+> - ppr (getSrcLoc id)))] - in - return (tidy_env', Just msg) - -find_thing ignore_it tidy_env (ATyVar tv ty) = do - tv_ty <- zonkTcType ty - if ignore_it tv_ty then - return (tidy_env, Nothing) - else let - -- The name tv is scoped, so we don't need to tidy it - (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty - msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at] - - eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, - getOccName tv == getOccName tv' = empty - | otherwise = equals <+> ppr tidy_ty - -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) - in - return (tidy_env1, Just msg) - -find_thing _ _ thing = pprPanic "find_thing" (ppr thing) -\end{code} - -%************************************************************************ -%* * -\subsection{The global tyvars} -%* * -%************************************************************************ - -\begin{code} -tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet) -tc_extend_gtvs gtvs extra_global_tvs = do - global_tvs <- readMutVar gtvs - newMutVar (global_tvs `unionVarSet` extra_global_tvs) -\end{code} + rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids] -@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. -To improve subsequent calls to the same function it writes the zonked set back into -the environment. - -\begin{code} -tcGetGlobalTyVars :: TcM TcTyVarSet -tcGetGlobalTyVars = do - (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv - gbl_tvs <- readMutVar gtv_var - gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs) - writeMutVar gtv_var gbl_tvs' - return gbl_tvs' +tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) +tcExtendGlobalTyVars gtv_var extra_global_tvs + = do { global_tvs <- readMutVar gtv_var + ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) } \end{code} @@ -504,7 +474,7 @@ tcGetGlobalTyVars = do \begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce + -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read -- its interface instead of its source code tcExtendRules lcl_rules thing_inside @@ -522,41 +492,25 @@ tcExtendRules lcl_rules thing_inside %************************************************************************ \begin{code} -instance Outputable ThStage where - ppr (Comp l) = text "Comp" <+> int l - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel (Comp l) = l -thLevel (Splice l) = l -thLevel (Brack l _ _) = l - - checkWellStaged :: SDoc -- What the stage check is for -> ThLevel -- Binding level (increases inside brackets) - -> ThStage -- Use stage + -> ThLevel -- Use stage -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_stage +checkWellStaged pp_thing bind_lvl use_lvl | use_lvl >= bind_lvl -- OK! Used later than bound = return () -- E.g. \x -> [| $(f x) |] - | bind_lvl == topLevel -- GHC restriction on top level splices + | bind_lvl == outerLevel -- GHC restriction on top level splices = failWithTc $ sep [ptext (sLit "GHC stage restriction:") <+> pp_thing, - nest 2 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))] + nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,") + , ptext (sLit "and must be imported, not defined locally")])] | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) ptext (sLit "Stage error:") <+> pp_thing <+> hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, ptext (sLit "but used at stage") <+> ppr use_lvl] - where - use_lvl = thLevel use_stage - use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice") - | use_lvl == thLevel topAnnStage = ptext (sLit "an annotation") - | otherwise = panic "checkWellStaged" topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -568,19 +522,9 @@ topIdLvl :: Id -> ThLevel -- $( f x ) -- By the time we are prcessing the $(f x), the binding for "x" -- will be in the global env, not the local one. -topIdLvl id | isLocalId id = topLevel +topIdLvl id | isLocalId id = outerLevel | otherwise = impLevel --- Indicates the legal transitions on bracket( [| |] ). -bracketOK :: ThStage -> Maybe ThLevel -bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket -bracketOK stage = Just (thLevel stage + 1) - --- Indicates the legal transitions on splice($). -spliceOK :: ThStage -> Maybe ThLevel -spliceOK (Splice _) = Nothing -- Splice illegal inside splice -spliceOK stage = Just (thLevel stage - 1) - tcMetaTy :: Name -> TcM Type -- Given the name of a Template Haskell data type, -- return the type @@ -607,6 +551,58 @@ thTopLevelId id = isGlobalId id || isExternalName (idName id) %************************************************************************ %* * + getDefaultTys +%* * +%************************************************************************ + +\begin{code} +tcGetDefaultTys :: Bool -- True <=> interactive context + -> TcM ([Type], -- Default types + (Bool, -- True <=> Use overloaded strings + Bool)) -- True <=> Use extended defaulting rules +tcGetDefaultTys interactive + = do { dflags <- getDOpts + ; let ovl_strings = xopt Opt_OverloadedStrings dflags + extended_defaults = interactive + || xopt Opt_ExtendedDefaultRules dflags + -- See also Trac #1974 + flags = (ovl_strings, extended_defaults) + + ; mb_defaults <- getDeclaredDefaultTys + ; case mb_defaults of { + Just tys -> return (tys, flags) ; + -- User-supplied defaults + Nothing -> do + + -- No use-supplied default + -- Use [Integer, Double], plus modifications + { integer_ty <- tcMetaTy integerTyConName + ; checkWiredInTyCon doubleTyCon + ; string_ty <- tcMetaTy stringTyConName + ; let deflt_tys = opt_deflt extended_defaults unitTy -- Note [Default unitTy] + ++ [integer_ty, doubleTy] + ++ opt_deflt ovl_strings string_ty + ; return (deflt_tys, flags) } } } + where + opt_deflt True ty = [ty] + opt_deflt False _ = [] +\end{code} + +Note [Default unitTy] +~~~~~~~~~~~~~~~~~~~~~ +In interative mode (or with -XExtendedDefaultRules) we add () as the first type we +try when defaulting. This has very little real impact, except in the following case. +Consider: + Text.Printf.printf "hello" +This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't +want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to +default the 'a' to (), rather than to Integer (which is what would otherwise happen; +and then GHCi doesn't attempt to print the (). So in interactive mode, we add +() to the list of defaulting types. See Trac #1200. + + +%************************************************************************ +%* * \subsection{The InstInfo type} %* * %************************************************************************ @@ -624,8 +620,8 @@ as well as explicit user written ones. \begin{code} data InstInfo a = InstInfo { - iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! + iSpec :: Instance, -- Includes the dfun id. Its forall'd type + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } iDFunId :: InstInfo a -> DFunId @@ -636,23 +632,38 @@ data InstBindings a (LHsBinds a) -- Bindings for the instance methods [LSig a] -- User pragmas recorded for generating -- specialised instances + Bool -- True <=> This code came from a standalone deriving clause + -- Used only to improve error messages - | NewTypeDerived -- Used for deriving instances of newtypes, where the - CoercionI -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas. - -- The coercion maps from newtype to the representation type - -- (mentioning type variables bound by the forall'd iSpec variables) - -- E.g. newtype instance N [a] = N1 (Tree a) - -- co : N [a] ~ Tree a + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. + + Coercion -- The coercion maps from newtype to the representation type + -- (mentioning type variables bound by the forall'd iSpec variables) + -- E.g. newtype instance N [a] = N1 (Tree a) + -- co : N [a] ~ Tree a + + TyCon -- The TyCon is the newtype N. If it's indexed, then it's the + -- representation TyCon, so that tyConDataCons returns [N1], + -- the "data constructor". + -- See Note [Newtype deriving and unused constructors] + -- in TcDeriv pprInstInfo :: InstInfo a -> SDoc -pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] +pprInstInfo info = hang (ptext (sLit "instance")) + 2 (sep [ ifPprDebug (pprForAll tvs) + , pprThetaArrowTy theta, ppr tau + , ptext (sLit "where")]) + where + (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) + pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where - details (VanillaInst b _) = pprLHsBinds b - details (NewTypeDerived _) = text "Derived from the representation type" + details (VanillaInst b _ _) = pprLHsBinds b + details (NewTypeDerived {}) = text "Derived from the representation type" simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of @@ -673,30 +684,27 @@ name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas (ty:_) loc - = do { index <- nextDFunIndex - ; is_boot <- tcIsHsBoot +newDFunName clas tys loc + = do { is_boot <- tcIsHsBoot ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - occNameString (getDFunTyKey ty) - dfun_occ = mkDFunOcc info_string is_boot index - + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} Make a name for the representation tycon of a family instance. It's an -*external* name, like otber top-level names, and hence must be made with +*external* name, like other top-level names, and hence must be made with newGlobalBinder. \begin{code} -newFamInstTyConName :: Name -> SrcSpan -> TcM Name -newFamInstTyConName tc_name loc - = do { index <- nextDFunIndex - ; mod <- getModule - ; let occ = nameOccName tc_name - ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name +newFamInstTyConName tc_name tys loc + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + concatMap (occNameString.getDFunTyKey) tys + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod occ loc } \end{code} Stable names used for foreign exports and annotations. @@ -734,12 +742,14 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs -notFound :: Name -> TcGblEnv -> TcM TyThing -notFound name env - = failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> +notFound :: Name -> TcM TyThing +notFound name + = do { (gbl,lcl) <- getEnvs + ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)] - ) + ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl), + ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)] + ) } wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name