X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=50cc4d6952f31483eb0325d857ef75f05da47348;hp=91ef46fa0b8f8ad6c115d2fabb725e6d961602bc;hb=0dc2b9de4dd4681aa11dfa5419c931a51b274fa6;hpb=f670c47f9f93ffd6d06b331cd40554cd5e92484c diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 91ef46f..50cc4d6 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -16,7 +16,7 @@ module TcHsType ( -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, tcLHsConResTy, + tcTyVarBndrs, dsHsType, kcHsLPred, dsHsLPred, tcDataKindSig, ExpKind(..), EkCtxt(..), -- Pattern type signatures @@ -40,7 +40,6 @@ import TcType import {- Kind parts of -} Type import Var import VarSet -import Coercion import TyCon import Class import Name @@ -159,10 +158,26 @@ tcHsSigTypeNC ctxt hs_ty tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type) -- Typecheck an instance head. We can't use -- tcHsSigType, because it's not a valid user type. -tcHsInstHead hs_ty - = do { kinded_ty <- kcHsSigType hs_ty - ; poly_ty <- tcHsKindedType kinded_ty - ; return (tcSplitSigmaTy poly_ty) } +tcHsInstHead (L loc ty) + = setSrcSpan loc $ -- No need for an "In the type..." context + tc_inst_head ty -- because that comes from the caller + where + -- tc_inst_head expects HsPredTy, which isn't usually even allowed + tc_inst_head (HsPredTy pred) + = do { pred' <- kcHsPred pred + ; pred'' <- dsHsPred pred' + ; return ([], [], mkPredTy pred'') } + + tc_inst_head (HsForAllTy _ tvs ctxt (L _ (HsPredTy pred))) + = kcHsTyVars tvs $ \ tvs' -> + do { ctxt' <- kcHsContext ctxt + ; pred' <- kcHsPred pred + ; tcTyVarBndrs tvs' $ \ tvs'' -> + do { ctxt'' <- mapM dsHsLPred (unLoc ctxt') + ; pred'' <- dsHsPred pred' + ; return (tvs'', ctxt'', mkPredTy pred'') } } + + tc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type")) tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), @@ -283,11 +298,6 @@ kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind ; return (mkHsAppTys fun_ty' arg_tys') } -kc_check_hs_type ty@(HsPredTy (HsClassP cls tys)) exp_kind - = do { cls_kind <- kcClass cls - ; tys' <- kcCheckApps cls cls_kind tys ty exp_kind - ; return (HsPredTy (HsClassP cls tys')) } - -- This is the general case: infer the kind and compare kc_check_hs_type ty exp_kind = do { (ty', act_kind) <- kc_hs_type ty @@ -306,7 +316,6 @@ kc_check_hs_type ty exp_kind strip (HsBangTy _ (L _ ty)) = strip ty strip (HsForAllTy _ _ _ (L _ ty)) = strip ty strip ty = ty - \end{code} Here comes the main function @@ -381,12 +390,11 @@ kc_hs_type (HsAppTy ty1 ty2) = do where (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 -kc_hs_type (HsPredTy (HsEqualP _ _)) - = wrongEqualityErr +kc_hs_type (HsPredTy pred) + = wrongPredErr pred -kc_hs_type (HsPredTy pred) = do - pred' <- kcHsPred pred - return (HsPredTy pred', liftedTypeKind) +kc_hs_type (HsCoreTy ty) + = return (HsCoreTy ty, typeKind ty) kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> @@ -413,11 +421,13 @@ kc_hs_type ty@(HsRecTy _) -- should have been removed by now #ifdef GHCI /* Only if bootstrapped */ -kc_hs_type (HsSpliceTy sp) = kcSpliceType sp +kc_hs_type (HsSpliceTy sp fvs _) = kcSpliceType sp fvs #else -kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) +kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) #endif +kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type" -- Eliminated by renamer + -- remove the doc nodes here, no need to worry about the location since -- its the same for a doc node and it's child type node kc_hs_type (HsDocTy ty _) @@ -464,7 +474,7 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) splitFunKind _ _ fk [] = return ([], fk) splitFunKind the_fun arg_no fk (arg:args) - = do { mb_fk <- unifyFunKind fk + = do { mb_fk <- matchExpectedFunKind fk ; case mb_fk of Nothing -> failWithTc too_many_args Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args @@ -511,9 +521,9 @@ kc_pred (HsEqualP ty1 ty2) --------------------------- kcTyVar :: Name -> TcM TcKind kcTyVar name = do -- Could be a tyvar or a tycon - traceTc (text "lk1" <+> ppr name) + traceTc "lk1" (ppr name) thing <- tcLookup name - traceTc (text "lk2" <+> ppr name <+> ppr thing) + traceTc "lk2" (ppr name <+> ppr thing) case thing of ATyVar _ ty -> return (typeKind ty) AThing kind -> return kind @@ -612,11 +622,16 @@ ds_type (HsForAllTy _ tv_names ctxt ty) tau <- dsHsType ty return (mkSigmaTy tyvars theta tau) -ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy" - ds_type (HsDocTy ty _) -- Remove the doc comment = dsHsType ty +ds_type (HsSpliceTy _ _ kind) + = do { kind' <- zonkTcKindToKind kind + ; newFlexiTyVarTy kind' } + +ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer +ds_type (HsCoreTy ty) = return ty + dsHsTypes :: [LHsType Name] -> TcM [Type] dsHsTypes arg_tys = mapM dsHsType arg_tys \end{code} @@ -670,35 +685,7 @@ dsHsPred (HsIParam name ty) } \end{code} -GADT constructor signatures - \begin{code} -tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType]) -tcLHsConResTy (L span res_ty) - = setSrcSpan span $ - case get_args res_ty [] of - (HsTyVar tc_name, args) - -> do { args' <- mapM dsHsType args - ; thing <- tcLookup tc_name - ; case thing of - AGlobal (ATyCon tc) -> return (tc, args') - _ -> failWithTc (badGadtDecl res_ty) } - _ -> failWithTc (badGadtDecl res_ty) - where - -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe - -- because that causes a black hole, and for good reason. Building - -- the type means expanding type synonyms, and we can't do that - -- inside the "knot". So we have to work by steam. - get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args) - get_args (HsParTy (L _ ty)) args = get_args ty args - get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args) - get_args ty args = (ty, args) - -badGadtDecl :: HsType Name -> SDoc -badGadtDecl ty - = hang (ptext (sLit "Malformed constructor result type:")) - 2 (ppr ty) - addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. addKcTypeCtxt (L _ (HsPredTy _)) thing = thing @@ -721,14 +708,14 @@ kcHsTyVars :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated -- They scope over the thing inside -> TcM r -kcHsTyVars tvs thing_inside = do - bndrs <- mapM (wrapLocM kcHsTyVar) tvs - tcExtendKindEnvTvs bndrs (thing_inside bndrs) +kcHsTyVars tvs thing_inside + = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs + ; tcExtendKindEnvTvs kinded_tvs thing_inside } kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it -kcHsTyVar (UserTyVar name) = KindedTyVar name <$> newKindVar -kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind) +kcHsTyVar (UserTyVar name _) = UserTyVar name <$> newKindVar +kcHsTyVar tv@(KindedTyVar {}) = return tv ------------------ tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking @@ -740,10 +727,9 @@ tcTyVarBndrs bndrs thing_inside = do tyvars <- mapM (zonk . unLoc) bndrs tcExtendTyVarEnv tyvars (thing_inside tyvars) where - zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind - ; return (mkTyVar name kind') } - zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name ) - return (mkTyVar name liftedTypeKind) + zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind + ; return (mkTyVar name kind') } + zonk (KindedTyVar name kind) = return (mkTyVar name kind) ----------------------------------- tcDataKindSig :: Maybe Kind -> TcM [TyVar] @@ -853,9 +839,9 @@ tcHsPatSigType ctxt hs_ty -- should be bound by the pattern signature in_scope <- getInLocalScope ; let span = getLoc hs_ty - sig_tvs = [ L span (UserTyVar n) - | n <- nameSetToList (extractHsTyVars hs_ty), - not (in_scope n) ] + sig_tvs = userHsTyVarBndrs $ map (L span) $ + filterOut in_scope $ + nameSetToList (extractHsTyVars hs_ty) ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty ; checkValidType ctxt sig_ty @@ -864,19 +850,23 @@ tcHsPatSigType ctxt hs_ty tcPatSig :: UserTypeCtxt -> LHsType Name - -> BoxySigmaType + -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables - CoercionI) -- Coercion due to unification with actual ty + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig + -- sig_tvs are the type variables free in 'sig', + -- and not already in scope. These are the ones + -- that should be brought into scope ; if null sig_tvs then do { -- The type signature binds no type variables, -- and hence is rigid, so use it to zap the res_ty - coi <- boxyUnify sig_ty res_ty - ; return (sig_ty, [], coi) + wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty + ; return (sig_ty, [], wrap) } else do { -- Type signature binds at least one scoped type variable @@ -890,9 +880,6 @@ tcPatSig ctxt sig res_ty _ -> False ; ASSERT( not in_pat_bind || null sig_tvs ) return () - -- Check that pat_ty is rigid - ; checkTc (isRigidTy res_ty) (wobblyPatSig sig_tvs) - -- Check that all newly-in-scope tyvars are in fact -- constrained by the pattern. This catches tiresome -- cases like @@ -903,24 +890,20 @@ tcPatSig ctxt sig res_ty ; let bad_tvs = filterOut (`elemVarSet` exactTyVarsOfType sig_ty) sig_tvs ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) - -- Now match the pattern signature against res_ty - -- For convenience, and uniform-looking error messages - -- we do the matching by allocating meta type variables, - -- unifying, and reading out the results. - -- This is a strictly local operation. - ; box_tvs <- mapM tcInstBoxyTyVar sig_tvs - ; coi <- boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) - res_ty - ; sig_tv_tys <- mapM readFilledBox box_tvs - - -- Check that each is bound to a distinct type variable, - -- and one that is not already in scope - ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys + -- Now do a subsumption check of the pattern signature against res_ty + ; sig_tvs' <- tcInstSigTyVars sig_tvs + ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty + sig_tv_tys' = mkTyVarTys sig_tvs' + ; wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty' + + -- Check that each is bound to a distinct type variable, + -- and one that is not already in scope ; binds_in_scope <- getScopedTyVarBinds + ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' ; check binds_in_scope tv_binds - -- Phew! - ; return (res_ty, tv_binds, coi) + -- Phew! + ; return (sig_ty', tv_binds, wrap) } } where check _ [] = return () @@ -928,14 +911,9 @@ tcPatSig ctxt sig res_ty ; check ((n,ty):in_scope) rest } check_one in_scope n ty - = do { checkTc (tcIsTyVarTy ty) (scopedNonVar n ty) - -- Must bind to a type variable - - ; checkTc (null dups) (dupInScope n (head dups) ty) + = checkTc (null dups) (dupInScope n (head dups) ty) -- Must not bind to the same type variable -- as some other in-scope type variable - - ; return () } where dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty] \end{code} @@ -1037,7 +1015,7 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) \begin{code} pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc -pprHsSigCtxt ctxt hs_ty = vcat [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> colon, +pprHsSigCtxt ctxt hs_ty = sep [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> colon, nest 2 (pp_sig ctxt) ] where pp_sig (FunSigCtxt n) = pp_n_colon n @@ -1047,12 +1025,6 @@ pprHsSigCtxt ctxt hs_ty = vcat [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> c pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) -wobblyPatSig :: [Var] -> SDoc -wobblyPatSig sig_tvs - = hang (ptext (sLit "A pattern type signature cannot bind scoped type variables") - <+> pprQuotedList sig_tvs) - 2 (ptext (sLit "unless the pattern has a rigid type context")) - badPatSigTvs :: TcType -> [TyVar] -> SDoc badPatSigTvs sig_ty bad_tvs = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, @@ -1062,20 +1034,13 @@ badPatSigTvs sig_ty bad_tvs , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] -scopedNonVar :: Name -> Type -> SDoc -scopedNonVar n ty - = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n), - nest 2 (ptext (sLit "is bound to the type") <+> quotes (ppr ty))], - nest 2 (ptext (sLit "You can only bind scoped type variables to type variables"))] - dupInScope :: Name -> Name -> Type -> SDoc dupInScope n n' _ = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n')) 2 (vcat [ptext (sLit "are bound to the same type (variable)"), ptext (sLit "Distinct scoped type variables must be distinct")]) -wrongEqualityErr :: TcM (HsType Name, TcKind) -wrongEqualityErr - = failWithTc (text "Equality predicate used as a type") +wrongPredErr :: HsPred Name -> TcM (HsType Name, TcKind) +wrongPredErr pred = failWithTc (text "Predicate used as a type:" <+> ppr pred) \end{code}