From 0d129b4ff3c2495a7d2b5bb4b475167936672c1c Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 30 Sep 2009 10:47:03 +0000 Subject: [PATCH 1/1] Fix Trac #3540: malformed types Tidy up the way that predicates are handled inside types --- compiler/typecheck/TcBinds.lhs | 27 +++++++++++++----------- compiler/typecheck/TcHsType.lhs | 43 ++++++++++++++++++++++----------------- compiler/typecheck/TcMType.lhs | 19 ++++++++--------- 3 files changed, 48 insertions(+), 41 deletions(-) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index a71da2e..7a7edb4 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcPolyBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcPragFun, tcPrags, mkPragFun, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where @@ -423,21 +423,24 @@ pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp -tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl -tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec -tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) -tcPrag _ sig = pprPanic "tcPrag" (ppr sig) - - -tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag -tcSpecPrag poly_id hs_ty inl +-- Most of the work of specialisation is done by +-- the desugarer, guided by the SpecPrag +tcPrag poly_id (SpecSig _ hs_ty inl) = do { let name = idName poly_id ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } - -- Most of the work of specialisation is done by - -- the desugarer, guided by the SpecPrag - +tcPrag poly_id (SpecInstSig hs_ty) + = do { let name = idName poly_id + ; (tyvars, theta, tau) <- tcHsInstHead hs_ty + ; let spec_ty = mkSigmaTy tyvars theta tau + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) } + +tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) +tcPrag _ sig = pprPanic "tcPrag" (ppr sig) + + -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 77fefc2..e277e5f 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -159,10 +159,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 +299,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 +317,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 +391,8 @@ 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) = do - pred' <- kcHsPred pred - return (HsPredTy pred', liftedTypeKind) +kc_hs_type (HsPredTy pred) + = wrongPredErr pred kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> @@ -1080,8 +1086,7 @@ dupInScope n 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} diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 94c2d25..6d6d102 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1078,12 +1078,14 @@ checkValidType ctxt ty = do ThBrackCtxt | unboxed -> UT_Ok _ -> UT_NotOk - -- Check that the thing has kind Type, and is lifted if necessary - checkTc kind_ok (kindErr actual_kind) - -- Check the internal validity of the type itself check_type rank ubx_tup ty + -- Check that the thing has kind Type, and is lifted if necessary + -- Do this second, becuase we can't usefully take the kind of an + -- ill-formed type such as (a~Int) + checkTc kind_ok (kindErr actual_kind) + traceTc (text "checkValidType done" <+> ppr ty) checkValidMonoType :: Type -> TcM () @@ -1138,15 +1140,12 @@ check_type rank ubx_tup ty where (tvs, theta, tau) = tcSplitSigmaTy ty --- Naked PredTys don't usually show up, but they can as a result of --- {-# SPECIALISE instance Ord Char #-} --- The Right Thing would be to fix the way that SPECIALISE instance pragmas --- are handled, but the quick thing is just to permit PredTys here. -check_type _ _ (PredTy sty) - = do { dflags <- getDOpts - ; check_pred_ty dflags TypeCtxt sty } +-- Naked PredTys should, I think, have been rejected before now +check_type _ _ ty@(PredTy {}) + = failWithTc (text "Predicate used as a type:" <+> ppr ty) check_type _ _ (TyVarTy _) = return () + check_type rank _ (FunTy arg_ty res_ty) = do { check_type (decRank rank) UT_NotOk arg_ty ; check_type rank UT_Ok res_ty } -- 1.7.10.4