X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=e1b9bd31b70c912cf74f7b61754aa43d89c77fb6;hp=d8058d56a9ad1883831b5fcfb2cabda190e01b84;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=b64c0fec513d83ea523af1c87c70eaedc0e26f9b diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d8058d5..e1b9bd3 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -1,3 +1,7 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -13,13 +17,13 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, + tcLookupLocatedClass, tcLookupFamInst, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, lclEnvElts, getInLocalScope, findGlobals, wrongThingErr, pprBinders, @@ -38,38 +42,35 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName ) where #include "HsVersions.h" -import HsSyn ( LRuleDecl, LHsBinds, LSig, - LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds ) -import TcIface ( tcImportDecl ) -import IfaceEnv ( newGlobalBinder ) +import HsSyn +import TcIface +import IfaceEnv import TcRnMonad -import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, - getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, - tidyOpenType, isRefineableTy - ) -import qualified Type ( getTyVar_maybe ) -import Id ( idName, isLocalId, setIdType ) -import Var ( TyVar, Id, idType, tyVarName ) +import TcMType +import TcType +import TcGadt +import qualified Type +import Id +import Var import VarSet import VarEnv -import RdrName ( extendLocalRdrEnv ) -import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) -import DataCon ( DataCon ) -import TyCon ( TyCon ) -import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) -import PrelNames ( thFAKE ) +import RdrName +import InstEnv +import FamInstEnv +import DataCon +import TyCon +import Class +import Name +import PrelNames import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) -import SrcLoc ( SrcLoc, Located(..) ) +import OccName +import HscTypes +import SrcLoc import Outputable \end{code} @@ -104,18 +105,21 @@ tcLookupGlobal name -- Try global envt { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of { + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> do -- Should it have been in the local envt? - { let mod = nameModule name - ; if mod == tcg_mod env || mod == thFAKE then - notFound name -- It should be local, so panic - -- The thFAKE possibility is because it - -- might be in a declaration bracket - else - tcImportDecl name -- Go find it in an interface + { case nameModule_maybe name of + Nothing -> notFound name -- Internal names can happen in GHCi + + Just mod | mod == tcg_mod env -- Names from this module + -> notFound name -- should be in tcg_type_env + | mod == thFAKE -- Names bound in TH declaration brackets + -> notFound name -- should be in tcg_env + | otherwise + -> tcImportDecl name -- Go find it in an interface }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id @@ -154,6 +158,25 @@ tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon + +-- Look up the representation tycon of a family instance. +-- Return the rep tycon and the corresponding rep args +tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) +tcLookupFamInst tycon tys + | not (isOpenTyCon tycon) + = return (tycon, tys) + | otherwise + = do { env <- getGblEnv + ; eps <- getEps + ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) + ; case lookupFamInstEnv instEnv tycon tys of + [(subst,fam_inst)] -> return (rep_tc, substTyVars subst (tyConTyVars rep_tc)) + where -- NB: assumption is that (tyConTyVars rep_tc) is in + -- the domain of the substitution + rep_tc = famInstTyCon fam_inst + + other -> famInstNotFound tycon tys other + } \end{code} %************************************************************************ @@ -215,21 +238,16 @@ tcLookupTyVar name other -> pprPanic "tcLookupTyVar" (ppr name) tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level --- Never a DataCon. (Why does that matter? see TcExpr.tcId) +-- Used when we aren't interested in the binding level, nor refinement. +-- The "no refinement" part means that we return the un-refined Id regardless +-- +-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) tcLookupId name = tcLookup name `thenM` \ thing -> case thing of - ATcId tc_id _ _ -> returnM tc_id - AGlobal (AnId id) -> returnM id - other -> pprPanic "tcLookupId" (ppr name) - -tcLookupLocalId_maybe :: Name -> TcM (Maybe Id) -tcLookupLocalId_maybe name - = getLclEnv `thenM` \ local_env -> - case lookupNameEnv (tcl_env local_env) name of - Just (ATcId tc_id _ _) -> return (Just tc_id) - other -> return Nothing + ATcId { tct_id = id} -> returnM id + AGlobal (AnId id) -> returnM id + other -> pprPanic "tcLookupId" (ppr name) tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at @@ -240,8 +258,9 @@ tcLookupLocalIds ns where lookup lenv lvl name = case lookupNameEnv lenv name of - Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id - other -> pprPanic "tcLookupLocalIds" (ppr name) + Just (ATcId { tct_id = id, tct_level = lvl1 }) + -> ASSERT( lvl == lvl1 ) id + other -> pprPanic "tcLookupLocalIds" (ppr name) lclEnvElts :: TcLclEnv -> [TcTyThing] lclEnvElts env = nameEnvElts (tcl_env env) @@ -321,8 +340,13 @@ tcExtendIdEnv2 names_w_ids thing_inside let extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids] th_lvl = thLevel (tcl_th_ctxt env) - extra_env = [ (name, ATcId id th_lvl (isRefineableTy (idType id))) - | (name,id) <- names_w_ids] + extra_env = [ (name, ATcId { tct_id = id, + tct_level = th_lvl, + tct_type = id_ty, + tct_co = if isRefineableTy id_ty + then Just idHsWrapper + else Nothing }) + | (name,id) <- names_w_ids, let id_ty = idType id] le' = extendNameEnvList (tcl_env env) extra_env rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids] in @@ -356,10 +380,10 @@ findGlobals tvs tidy_env Just d -> go tidy_env1 (d:acc) things Nothing -> go tidy_env1 acc things - ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty) + ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty ----------------------- -find_thing ignore_it tidy_env (ATcId id _ _) +find_thing ignore_it tidy_env (ATcId { tct_id = id }) = zonkTcType (idType id) `thenM` \ id_ty -> if ignore_it id_ty then returnM (tidy_env, Nothing) @@ -392,16 +416,25 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) \end{code} \begin{code} -refineEnvironment :: TvSubst -> TcM a -> TcM a +refineEnvironment :: Refinement -> TcM a -> TcM a +-- I don't think I have to refine the set of global type variables in scope +-- Reason: the refinement never increases that set refineEnvironment reft thing_inside + | isEmptyRefinement reft -- Common case + = thing_inside + | otherwise = do { env <- getLclEnv ; let le' = mapNameEnv refine (tcl_env env) - ; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env) - ; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside } + ; setLclEnv (env {tcl_env = le'}) thing_inside } where - refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True - refine (ATyVar tv ty) = ATyVar tv (substTy reft ty) - refine elt = elt + refine elt@(ATcId { tct_co = Just co, tct_type = ty }) + | Just (co', ty') <- refineType reft ty + = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' } + refine (ATyVar tv ty) + | Just (_, ty') <- refineType reft ty + = ATyVar tv ty' -- Ignore the coercion that refineType returns + + refine elt = elt -- Common case \end{code} %************************************************************************ @@ -414,11 +447,6 @@ refineEnvironment reft thing_inside tc_extend_gtvs gtvs extra_global_tvs = readMutVar gtvs `thenM` \ global_tvs -> newMutVar (global_tvs `unionVarSet` extra_global_tvs) - -refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet) -refineGlobalTyVars reft gtv_var - = readMutVar gtv_var `thenM` \ gbl_tvs -> - newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs))) \end{code} @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. @@ -562,11 +590,19 @@ data InstBindings [LSig Name] -- User pragmas recorded for generating -- specialised instances - | NewTypeDerived -- Used for deriving instances of newtypes, where the - [Type] -- witness dictionary is identical to the argument - -- dictionary. Hence no bindings, no pragmas - -- The [Type] are the representation types - -- See notes in TcDeriv + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. + (Maybe [PredType]) + -- Nothing => The newtype-derived instance involves type variables, + -- and the dfun has a type like df :: forall a. Eq a => Eq (T a) + -- Just (r:scs) => The newtype-defined instance has no type variables + -- so the dfun is just a constant, df :: Eq T + -- In this case we need to know waht the rep dict, r, and the + -- superclasses, scs, are. (In the Nothing case these are in the + -- dict fun's type.) + -- Invariant: these PredTypes have no free variables + -- NB: In both cases, the representation dict is the *first* dict. pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] @@ -601,11 +637,24 @@ newDFunName clas (ty:_) loc occNameString (getDFunTyKey ty) dfun_occ = mkDFunOcc info_string is_boot index - ; newGlobalBinder mod dfun_occ Nothing loc } + ; 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 data/newtype instance. It's an +*external* name, like otber top-level names, and hence must be made with +newGlobalBinder. + +\begin{code} +newFamInstTyConName :: Name -> SrcLoc -> TcM Name +newFamInstTyConName tc_name loc + = do { index <- nextDFunIndex + ; mod <- getModule + ; let occ = nameOccName tc_name + ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +\end{code} + %************************************************************************ %* * @@ -627,4 +676,11 @@ notFound name wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected) + +famInstNotFound tycon tys what + = failWithTc (msg <+> quotes (ppr tycon <+> hsep (map pprParendType tys))) + where + msg = case what of + [] -> ptext SLIT("No instance for") + xs -> ptext SLIT("More than one instance for") \end{code}