X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=11288dc6d8500b614208e0309cd3023131b69f1b;hb=8f53119f5772a8c8dc9fd08065cc86df7a4f0b26;hp=a63c2cee907628454d2e9c1baad18f60daee5a08;hpb=432b9c9322181a3644083e3c19b7e240d90659e7;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index a63c2ce..11288dc 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -39,21 +39,20 @@ import TcIface import TcType import {- Kind parts of -} Type import Var +import VarSet import Coercion import TyCon import Class import Name -import OccName import NameSet import PrelNames import TysWiredIn import BasicTypes import SrcLoc +import Util import UniqSupply import Outputable import FastString - -import Control.Monad \end{code} @@ -160,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), @@ -284,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 @@ -307,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 @@ -382,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' -> @@ -416,9 +421,11 @@ kc_hs_type ty@(HsRecTy _) #ifdef GHCI /* Only if bootstrapped */ kc_hs_type (HsSpliceTy sp) = kcSpliceType sp #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 (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all + -- 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 _) @@ -613,11 +620,15 @@ 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 (HsSpliceTyOut kind) + = do { kind' <- zonkTcKindToKind kind + ; newFlexiTyVarTy kind' } + +ds_type (HsSpliceTy {}) = panic "ds_type" + dsHsTypes :: [LHsType Name] -> TcM [Type] dsHsTypes arg_tys = mapM dsHsType arg_tys \end{code} @@ -894,6 +905,16 @@ tcPatSig ctxt sig res_ty -- 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 + -- type T a = Int + -- f :: Int -> Int + -- f (x :: T a) = ... + -- Here 'a' doesn't get a binding. Sigh + ; 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, @@ -1028,7 +1049,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 @@ -1044,6 +1065,15 @@ wobblyPatSig sig_tvs <+> 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, + quotes (pprWithCommas ppr bad_tvs), + ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty), + ptext (sLit "but are actually discarded by a type synonym") ] + , 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), @@ -1056,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}