From bc7bd6e3afa5d5d97d8eda26b79ac18cef0a0b42 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 2 Apr 2004 12:38:35 +0000 Subject: [PATCH] [project @ 2004-04-02 12:38:33 by simonpj] A preliminary step towards being able to identify existential type variables separately. That in turn helps when resolving overloading; I think we want to resolve overloading without worrying about what these type variables might instantiate to. --- ghc/compiler/typecheck/Inst.lhs | 30 ++++++++++++++++++++---------- ghc/compiler/typecheck/TcExpr.lhs | 6 +++--- ghc/compiler/typecheck/TcPat.lhs | 6 +++--- ghc/compiler/typecheck/TcType.lhs | 25 ++++++++++++++++++++----- 4 files changed, 46 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 655684a..5e82933 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -74,7 +74,7 @@ import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique import PrelInfo ( isStandardClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName ) import NameSet ( addOneToNameSet ) -import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) +import Subst ( substTy, substTyWith, substTheta, mkTopTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar, tyVarKind ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) @@ -277,27 +277,34 @@ tcInstCall orig fun_ty -- fun_ty is usually a sigma-type in returnM (mkCoercion inst_fn, tau) -tcInstDataCon :: InstOrigin -> DataCon +tcInstDataCon :: InstOrigin + -> TyVarDetails -- Use this for the existential tyvars + -- ExistTv when pattern-matching, + -- VanillaTv at a call of the constructor + -> DataCon -> TcM ([TcType], -- Types to instantiate at [Inst], -- Existential dictionaries to apply to [TcType], -- Argument types of constructor TcType, -- Result type [TyVar]) -- Existential tyvars -tcInstDataCon orig data_con +tcInstDataCon orig ex_tv_details data_con = let (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con -- We generate constraints for the stupid theta even when -- pattern matching (as the Report requires) in - tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) -> + mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' -> + mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' -> let + tv_tys' = mkTyVarTys tvs' + ex_tv_tys' = mkTyVarTys ex_tvs' + all_tys' = tv_tys' ++ ex_tv_tys' + + tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys' stupid_theta' = substTheta tenv stupid_theta ex_theta' = substTheta tenv ex_theta arg_tys' = map (substTy tenv) arg_tys - - n_normal_tvs = length tvs - ex_tvs' = drop n_normal_tvs all_tvs' - result_ty = mkTyConApp tycon (take n_normal_tvs ty_args') + result_ty' = mkTyConApp tycon tv_tys' in newDicts orig stupid_theta' `thenM` \ stupid_dicts -> newDicts orig ex_theta' `thenM` \ ex_dicts -> @@ -306,7 +313,7 @@ tcInstDataCon orig data_con -- we don't otherwise use it at all extendLIEs stupid_dicts `thenM_` - returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs') + returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs') newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId newMethodFromName origin ty name @@ -743,7 +750,10 @@ instantiate_dfun tenv dfun_id pred loc in mappM mk_ty_arg tyvars `thenM` \ ty_args -> let - dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho + dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho + -- Since the tyvars are freshly made, + -- they cannot possibly be captured by + -- any existing for-alls. Hence mkTopTyVarSubst (theta, _) = tcSplitPhiTy dfun_rho ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args in diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index d0328f9..a66147e 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -839,9 +839,9 @@ tcId name -- Look up the Id and instantiate its type -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs -- It's dual to TcPat.tcConstructor inst_data_con data_con - = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> - extendLIEs ex_dicts `thenM_` - getSrcSpanM `thenM` \ loc -> + = tcInstDataCon orig VanillaTv data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> + extendLIEs ex_dicts `thenM_` + getSrcSpanM `thenM` \ loc -> returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args) (map instToId ex_dicts)), mkFunTys arg_tys result_ty) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 24cc1de..7c680f0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -26,7 +26,7 @@ import Name ( Name ) import FieldLabel ( fieldLabelName ) import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId ) import TcMType ( newTyVarTy, arityErr ) -import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred ) +import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(..), mkClassPred ) import Kind ( argTypeKind, liftedTypeKind ) import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) @@ -229,8 +229,8 @@ tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty = addErrCtxt (patCtxt pat_in) $ -- Check that it's a constructor, and instantiate it - tcLookupLocatedDataCon con_name `thenM` \ data_con -> - tcInstDataCon (PatOrigin pat_in) data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) -> + tcLookupLocatedDataCon con_name `thenM` \ data_con -> + tcInstDataCon (PatOrigin pat_in) ExistTv data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) -> -- Check overall type matches. -- The pat_ty might be a for-all type, in which diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index e41c696..0e430f4 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,7 +22,7 @@ module TcType ( -------------------------------- -- TyVarDetails - TyVarDetails(..), isUserTyVar, isSkolemTyVar, + TyVarDetails(..), isUserTyVar, isSkolemTyVar, isExistentialTyVar, tyVarBindingInfo, -------------------------------- @@ -248,6 +248,14 @@ data TyVarDetails | PatSigTv -- Scoped type variable, introduced by a pattern -- type signature \ x::a -> e + | ExistTv -- An existential type variable bound by a pattern for + -- a data constructor with an existential type. E.g. + -- data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. We distinguish these from all others + -- on one place, namely InstEnv.lookupInstEnv. + | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible @@ -257,10 +265,16 @@ isUserTyVar tv = case tcTyVarDetails tv of isSkolemTyVar :: TcTyVar -> Bool isSkolemTyVar tv = case tcTyVarDetails tv of - SigTv -> True - ClsTv -> True - InstTv -> True - oteher -> False + SigTv -> True + ClsTv -> True + InstTv -> True + ExistTv -> True + other -> False + +isExistentialTyVar :: TcTyVar -> Bool +isExistentialTyVar tv = case tcTyVarDetails tv of + ExistTv -> True + other -> False tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars tyVarBindingInfo tv @@ -271,6 +285,7 @@ tyVarBindingInfo tv details ClsTv = ptext SLIT("class declaration") details InstTv = ptext SLIT("instance declaration") details PatSigTv = ptext SLIT("pattern type signature") + details ExistTv = ptext SLIT("existential constructor") details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} -- 1.7.10.4