X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=1d093e2e7c4d1aa2a2760c25def972c16e72be7a;hb=15cb792d18b1094e98c035dca6ecec5dad516056;hp=c5d65c26ace1b81fe3b146eeb1471d4d559fb8c7;hpb=df0878586620fee9ea5ecbe4d377006c88ad498f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index c5d65c2..1d093e2 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -19,7 +19,7 @@ module TcEnv( tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds, lclEnvElts, getInLocalScope, findGlobals, wrongThingErr, pprBinders, @@ -44,18 +44,20 @@ module TcEnv( #include "HsVersions.h" import HsSyn ( LRuleDecl, LHsBinds, LSig, - LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds ) + LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds, + idCoercion, (<.>) ) import TcIface ( tcImportDecl ) import IfaceEnv ( newGlobalBinder ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, +import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, + substTy, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, tidyOpenType, isRefineableTy ) +import TcGadt ( Refinement, refineType ) import qualified Type ( getTyVar_maybe ) -import Id ( idName, isLocalId, setIdType ) +import Id ( idName, isLocalId ) import Var ( TyVar, Id, idType, tyVarName ) import VarSet import VarEnv @@ -64,14 +66,11 @@ import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName ) +import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) import PrelNames ( thFAKE ) import NameEnv import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, - TyThing(..), tyThingId, tyThingDataCon, - ExternalPackageState(..) ) - +import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) import SrcLoc ( SrcLoc, Located(..) ) import Outputable \end{code} @@ -107,7 +106,8 @@ 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 @@ -218,21 +218,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 @@ -243,8 +238,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) @@ -324,8 +320,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 idCoercion + 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 @@ -362,7 +363,7 @@ findGlobals tvs tidy_env ignore_it ty = not (tvs `intersectsVarSet` 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) @@ -395,16 +396,20 @@ 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 = 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 }) + = let (co', ty') = refineType reft ty + in elt { tct_co = Just (co' <.> co), tct_type = ty' } + refine (ATyVar tv ty) = ATyVar tv (snd (refineType reft ty)) + -- Ignore the coercion that refineType returns + refine elt = elt \end{code} %************************************************************************ @@ -417,11 +422,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. @@ -565,7 +565,9 @@ data InstBindings [LSig Name] -- User pragmas recorded for generating -- specialised instances - | NewTypeDerived -- Used for deriving instances of newtypes, where the + | NewTypeDerived + TyCon -- tycon for the newtype + -- 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 @@ -576,7 +578,7 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where details (VanillaInst b _) = pprLHsBinds b - details (NewTypeDerived _) = text "Derived from the representation type" + details (NewTypeDerived _ _) = text "Derived from the representation type" simpleInstInfoClsTy :: InstInfo -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of