X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=e277e5fe6083d180d2c776a1d693ae3fcd9b766f;hp=c8c0efcde421860318aa1561609a634647e133ca;hb=0d129b4ff3c2495a7d2b5bb4b475167936672c1c;hpb=389cca214f33a29646e08d57e3dca862140007b2 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index c8c0efc..e277e5f 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' -> @@ -404,16 +409,23 @@ kc_hs_type (HsForAllTy exp tv_names context ty) ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) } -kc_hs_type (HsBangTy b ty) = do - (ty', kind) <- kc_lhs_type ty - return (HsBangTy b ty', kind) +kc_hs_type (HsBangTy b ty) + = do { (ty', kind) <- kc_lhs_type ty + ; return (HsBangTy b ty', kind) } + +kc_hs_type ty@(HsRecTy _) + = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty) + -- Record types (which only show up temporarily in constructor signatures) + -- should have been removed by now #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 _) @@ -554,9 +566,12 @@ ds_type ty@(HsTyVar _) ds_type (HsParTy ty) -- Remove the parentheses markers = dsHsType ty -ds_type ty@(HsBangTy _ _) -- No bangs should be here +ds_type ty@(HsBangTy {}) -- No bangs should be here = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) +ds_type ty@(HsRecTy {}) -- No bangs should be here + = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty) + ds_type (HsKindSig ty _) = dsHsType ty -- Kind checking done already @@ -605,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} @@ -886,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, @@ -1036,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), @@ -1048,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}