X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=4fe6b60376461ec9bc3b870cf7fb99f13e1a4114;hp=50cc4d6952f31483eb0325d857ef75f05da47348;hb=HEAD;hpb=2b8358cfe8b6399874090c099e3b96e932c6ccbb diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 50cc4d6..4fe6b60 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -37,6 +37,7 @@ import TcMType import TcUnify import TcIface import TcType +import TysPrim ( ecKind ) import {- Kind parts of -} Type import Var import VarSet @@ -44,7 +45,6 @@ import TyCon import Class import Name import NameSet -import PrelNames import TysWiredIn import BasicTypes import SrcLoc @@ -155,29 +155,36 @@ tcHsSigTypeNC ctxt hs_ty ; checkValidType ctxt ty ; return ty } -tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type) +tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) -- Typecheck an instance head. We can't use -- tcHsSigType, because it's not a valid user type. -tcHsInstHead (L loc ty) +tcHsInstHead (L loc hs_ty) = setSrcSpan loc $ -- No need for an "In the type..." context - tc_inst_head ty -- because that comes from the caller + -- because that comes from the caller + do { kinded_ty <- kc_inst_head hs_ty + ; ds_inst_head kinded_ty } 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")) + kc_inst_head ty@(HsPredTy pred@(HsClassP {})) + = do { (pred', kind) <- kc_pred pred + ; checkExpectedKind ty kind ekLifted + ; return (HsPredTy pred') } + kc_inst_head (HsForAllTy exp tv_names context (L loc ty)) + = kcHsTyVars tv_names $ \ tv_names' -> + do { ctxt' <- kcHsContext context + ; ty' <- kc_inst_head ty + ; return (HsForAllTy exp tv_names' ctxt' (L loc ty')) } + kc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type")) + + ds_inst_head (HsPredTy (HsClassP cls_name tys)) + = do { clas <- tcLookupClass cls_name + ; arg_tys <- dsHsTypes tys + ; return ([], [], clas, arg_tys) } + ds_inst_head (HsForAllTy _ tvs ctxt (L _ tau)) + = tcTyVarBndrs tvs $ \ tvs' -> + do { ctxt' <- mapM dsHsLPred (unLoc ctxt) + ; (tvs_r, ctxt_r, cls, tys) <- ds_inst_head tau + ; return (tvs' ++ tvs_r, ctxt' ++ ctxt_r , cls, tys) } + ds_inst_head _ = panic "ds_inst_head" tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), @@ -293,7 +300,7 @@ kc_check_hs_type (HsParTy ty) exp_kind = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') } kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind - = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind ; return (mkHsAppTys fun_ty' arg_tys') } @@ -358,8 +365,15 @@ kc_hs_type (HsPArrTy ty) = do ty' <- kcLiftedType ty return (HsPArrTy ty', liftedTypeKind) -kc_hs_type (HsNumTy n) - = return (HsNumTy n, liftedTypeKind) +kc_hs_type (HsModalBoxType ecn ty) = do + kc_check_hs_type (HsTyVar ecn) (EK ecKind EkUnk) + ty' <- kcLiftedType ty + return (HsModalBoxType ecn ty', liftedTypeKind) + +kc_hs_type (HsKappaTy ty1 ty2) = do + ty1' <- kc_check_lhs_type ty1 (EK argTypeKind EkUnk) + ty2' <- kcTypeType ty2 + return (HsKappaTy ty1' ty2', liftedTypeKind) kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) @@ -384,11 +398,10 @@ kc_hs_type (HsOpTy ty1 op ty2) = do return (HsOpTy ty1' op ty2', res_kind) kc_hs_type (HsAppTy ty1 ty2) = do + let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] (fun_ty', fun_kind) <- kc_lhs_type fun_ty (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys return (mkHsAppTys fun_ty' arg_tys', res_kind) - where - (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 kc_hs_type (HsPredTy pred) = wrongPredErr pred @@ -455,20 +468,6 @@ kcCheckApps the_fun fun_kind args ty exp_kind -- This improves error message; Trac #2994 ; kc_check_lhs_types args_w_kinds } -splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name]) -splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty] - where - split (L _ (HsAppTy f a)) as = split f (a:as) - split f as = (f,as) - -mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name -mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) -mkHsAppTys fun_ty (arg_ty:arg_tys) - = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys - where - mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of - -- the application; they are - -- never used --------------------------- splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) @@ -491,9 +490,9 @@ kcHsLPred :: LHsPred Name -> TcM (LHsPred Name) kcHsLPred = wrapLocM kcHsPred kcHsPred :: HsPred Name -> TcM (HsPred Name) -kcHsPred pred = do -- Checks that the result is of kind liftedType +kcHsPred pred = do -- Checks that the result is a type kind (pred', kind) <- kc_pred pred - checkExpectedKind pred kind ekLifted + checkExpectedKind pred kind ekOpen return pred' --------------------------- @@ -502,21 +501,16 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) -- application (reason: used from TcDeriv) kc_pred (HsIParam name ty) = do { (ty', kind) <- kc_lhs_type ty - ; return (HsIParam name ty', kind) - } + ; return (HsIParam name ty', kind) } kc_pred (HsClassP cls tys) = do { kind <- kcClass cls ; (tys', res_kind) <- kcApps cls kind tys - ; return (HsClassP cls tys', res_kind) - } + ; return (HsClassP cls tys', res_kind) } kc_pred (HsEqualP ty1 ty2) = do { (ty1', kind1) <- kc_lhs_type ty1 --- ; checkExpectedKind ty1 kind1 liftedTypeKind ; (ty2', kind2) <- kc_lhs_type ty2 --- ; checkExpectedKind ty2 kind2 liftedTypeKind ; checkExpectedKind ty2 kind2 (EK kind1 EkEqPred) - ; return (HsEqualP ty1' ty2', liftedTypeKind) - } + ; return (HsEqualP ty1' ty2', unliftedTypeKind) } --------------------------- kcTyVar :: Name -> TcM TcKind @@ -587,6 +581,16 @@ ds_type (HsPArrTy ty) = do checkWiredInTyCon parrTyCon return (mkPArrTy tau_ty) +ds_type (HsModalBoxType ecn ty) = do + tau_ty <- dsHsType ty + checkWiredInTyCon hetMetCodeTypeTyCon + return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty) + +ds_type (HsKappaTy ty1 ty2) = do + tau_ty1 <- dsHsType ty1 + tau_ty2 <- dsHsType ty2 + return (mkHetMetKappaTy tau_ty1 tau_ty2) + ds_type (HsTupleTy boxity tys) = do tau_tys <- dsHsTypes tys checkWiredInTyCon tycon @@ -604,11 +608,6 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do tau_ty2 <- dsHsType ty2 setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) -ds_type (HsNumTy n) - = ASSERT(n==1) do - tc <- tcLookupTyCon genUnitTyConName - return (mkTyConApp tc []) - ds_type ty@(HsAppTy _ _) = ds_app ty [] @@ -855,7 +854,7 @@ tcPatSig :: UserTypeCtxt [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_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', @@ -865,10 +864,9 @@ tcPatSig ctxt sig res_ty ; 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 - wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty + wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - - } else do { + } else do { -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables @@ -891,20 +889,20 @@ tcPatSig ctxt sig res_ty ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs + ; 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' + ; wrap <- tcSubType PatSigOrigin 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 + ; binds_in_scope <- getScopedTyVarBinds ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' ; check binds_in_scope tv_binds -- Phew! - ; return (sig_ty', tv_binds, wrap) - } } + ; return (sig_ty', tv_binds, wrap) + } } where check _ [] = return () check in_scope ((n,ty):rest) = do { check_one in_scope n ty @@ -915,7 +913,7 @@ tcPatSig ctxt sig res_ty -- Must not bind to the same type variable -- as some other in-scope type variable where - dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty] + dups = [n' | (n',ty') <- in_scope, eqType ty' ty] \end{code}