X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=c7385e2912a06dba65b958494aaeba2190de4f4a;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=08a3cbd6ee79fed2654b87f13126d27208ddac8e;hpb=389cca214f33a29646e08d57e3dca862140007b2;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 08a3cbd..c7385e2 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -70,7 +70,8 @@ import TyCon import Var -- others: -import TcRnMonad -- TcType, amongst others +import HsSyn -- HsType +import TcRnMonad -- TcType, amongst others import FunDeps import Name import VarEnv @@ -415,7 +416,7 @@ occurCheckErr ty containingTy newCoVars :: [(TcType,TcType)] -> TcM [CoVar] newCoVars spec = do { us <- newUniqueSupply - ; return [ mkCoVar (mkSysTvName uniq (fsLit "co")) + ; return [ mkCoVar (mkSysTvName uniq (fsLit "co_kv")) (mkCoKind ty1 ty2) | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] } @@ -945,14 +946,14 @@ zonkType unbound_var_fn ty zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable var -> TcTyVar -> TcM TcType zonk_tc_tyvar unbound_var_fn tyvar - | not (isMetaTyVar tyvar) -- Skolems - = return (TyVarTy tyvar) - - | otherwise -- Mutables - = do { cts <- readMetaTyVar tyvar - ; case cts of - Flexi -> unbound_var_fn tyvar -- Unbound meta type variable - Indirect ty -> zonkType unbound_var_fn ty } + = ASSERT( isTcTyVar tyvar ) + case tcTyVarDetails tyvar of + SkolemTv {} -> return (TyVarTy tyvar) + FlatSkol ty -> zonkType unbound_var_fn ty + MetaTv _ ref -> do { cts <- readMutVar ref + ; case cts of + Flexi -> unbound_var_fn tyvar + Indirect ty -> zonkType unbound_var_fn ty } -- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their -- kind contains types). @@ -1078,12 +1079,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 +1141,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 } @@ -1530,7 +1530,8 @@ dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas p arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"), - n_arguments <> comma, text "but has been given", int m] + n_arguments <> comma, text "but has been given", + if m==0 then text "none" else int m] where n_arguments | n == 0 = ptext (sLit "no arguments") | n == 1 = ptext (sLit "1 argument") @@ -1639,11 +1640,15 @@ instTypeErr pp_ty msg %* * %************************************************************************ - \begin{code} -checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM () -checkValidInstance tyvars theta clas inst_tys - = do { undecidable_ok <- doptM Opt_UndecidableInstances +checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType -> Type + -> TcM (Class, [TcType]) +checkValidInstance hs_type tyvars theta tau + = setSrcSpan (getLoc hs_type) $ + do { (clas, inst_tys) <- setSrcSpan head_loc $ + checkValidInstHead tau + + ; undecidable_ok <- doptM Opt_UndecidableInstances ; checkValidTheta InstThetaCtxt theta ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) @@ -1657,10 +1662,17 @@ checkValidInstance tyvars theta clas inst_tys -- The Coverage Condition ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) + + ; return (clas, inst_tys) } where msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) + + -- The location of the "head" of the instance + head_loc = case hs_type of + L _ (HsForAllTy _ _ _ (L loc _)) -> loc + L loc _ -> loc \end{code} Termination test: the so-called "Paterson conditions" (see Section 5 of @@ -1728,7 +1740,6 @@ Notice that this instance (just) satisfies the Paterson termination conditions. Then we *could* derive an instance decl like this: instance (C Int a, Eq b, Eq c) => Eq (T a b c) - even though there is no instance for (C Int a), because there just *might* be an instance for, say, (C Int Bool) at a site where we need the equality instance for T's. @@ -1892,8 +1903,16 @@ sizeType (ForAllTy _ ty) = sizeType ty sizeTypes :: [Type] -> Int sizeTypes xs = sum (map sizeType xs) +-- Size of a predicate +-- +-- Equalities are a special case. The equality itself doesn't contribute to the +-- size and as we do not count class predicates, we have to start with one less. +-- This is easy to see considering that, given +-- class C a b | a -> b +-- type family F a +-- constraints (C a b) and (F a ~ b) are equivalent in size. sizePred :: PredType -> Int sizePred (ClassP _ tys') = sizeTypes tys' sizePred (IParam _ ty) = sizeType ty -sizePred (EqPred ty1 ty2) = sizeType ty1 + sizeType ty2 +sizePred (EqPred ty1 ty2) = sizeType ty1 + sizeType ty2 - 1 \end{code}