Commit 0d129b4f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix Trac #3540: malformed types

Tidy up the way that predicates are handled inside types
parent cc7fd02d
......@@ -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
......
......@@ -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}
......@@ -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 }
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment