X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=1290e03cb6615f1ca933911ee843f8cc7245074b;hp=b9db015e1dafc4ad612848a0aa4289e6e798f0b5;hb=d3355c05e88c75e18045a7467aa73b8d48379770;hpb=a162b85d26966ba0eecc4d2ae02d4fd71f5cb9f8 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index b9db015..1290e03 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -9,13 +9,6 @@ This module contains monadic operations over types that contain mutable type variables \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcMType ( TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, @@ -58,7 +51,7 @@ module TcMType ( zonkType, zonkTcPredType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, - zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKindToKind, zonkTcKind, zonkTopTyVar, readKindVar, writeKindVar @@ -79,6 +72,7 @@ import Var import TcRnMonad -- TcType, amongst others import FunDeps import Name +import VarEnv import VarSet import ErrUtils import DynFlags @@ -90,7 +84,7 @@ import SrcLoc import Outputable import FastString -import Control.Monad ( when, unless ) +import Control.Monad import Data.List ( (\\) ) \end{code} @@ -160,6 +154,7 @@ updateMeta tv1 ref1 ty2 } ---------------- +checkKinds :: Bool -> TyVar -> Type -> TcM () checkKinds swapped tv1 ty2 -- We're about to unify a type variable tv1 with a non-tyvar-type ty2. -- ty2 has been zonked at this stage, which ensures that @@ -234,7 +229,7 @@ checkTauTvUpdate orig_tv orig_ty -- NB the mkAppTy; we might have instantiated a -- type variable to a type constructor, so we need -- to pull the TyConApp to the top. - go (ForAllTy tv ty) = notMonoType orig_ty -- (b) + go (ForAllTy _ _) = notMonoType orig_ty -- (b) go (TyVarTy tv) | orig_tv == tv = return $ Left False -- (a) @@ -259,7 +254,7 @@ checkTauTvUpdate orig_tv orig_ty Flexi -> case box of BoxTv -> do { ty <- fillBoxWithTau tv ref ; return $ Right ty } - other -> return $ Right (TyVarTy tv) + _ -> return $ Right (TyVarTy tv) } -- go_syn is called for synonyms only @@ -268,7 +263,7 @@ checkTauTvUpdate orig_tv orig_ty | not (isTauTyCon tc) = notMonoType orig_ty -- (b) again | otherwise - = do { (msgs, mb_tys') <- tryTc (mapM go tys) + = do { (_msgs, mb_tys') <- tryTc (mapM go tys) ; case mb_tys' of -- we had a type error => forall in type parameters @@ -344,22 +339,24 @@ Rather, we should bind t to () (= non_var_ty2). Error mesages in case of kind mismatch. \begin{code} +unifyKindMisMatch :: TcKind -> TcKind -> TcM () unifyKindMisMatch ty1 ty2 = do ty1' <- zonkTcKind ty1 ty2' <- zonkTcKind ty2 let - msg = hang (ptext SLIT("Couldn't match kind")) + msg = hang (ptext (sLit "Couldn't match kind")) 2 (sep [quotes (ppr ty1'), - ptext SLIT("against"), + ptext (sLit "against"), quotes (ppr ty2')]) failWithTc msg +unifyKindCtxt :: Bool -> TyVar -> Type -> TidyEnv -> TcM (TidyEnv, SDoc) unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred -- tv1 and ty2 are zonked already = return msg where - msg = (env2, ptext SLIT("When matching the kinds of") <+> - sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual]) + msg = (env2, ptext (sLit "When matching the kinds of") <+> + sep [quotes pp_expected <+> ptext (sLit "and"), quotes pp_actual]) (pp_expected, pp_actual) | swapped = (pp2, pp1) | otherwise = (pp1, pp2) @@ -382,7 +379,7 @@ occurCheckErr ty containingTy extra = sep [ppr tidy_ty1, char '=', ppr tidy_ty2] ; failWithTcM (env2, hang msg 2 extra) } where - msg = ptext SLIT("Occurs check: cannot construct the infinite type:") + msg = ptext (sLit "Occurs check: cannot construct the infinite type:") \end{code} %************************************************************************ @@ -395,7 +392,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")) (mkCoKind ty1 ty2) | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] } @@ -474,9 +471,9 @@ newMetaTyVar box_info kind ; ref <- newMutVar Flexi ; let name = mkSysTvName uniq fs fs = case box_info of - BoxTv -> FSLIT("t") - TauTv -> FSLIT("t") - SigTv _ -> FSLIT("a") + BoxTv -> fsLit "t" + TauTv -> fsLit "t" + SigTv _ -> fsLit "a" -- We give BoxTv and TauTv the same string, because -- otherwise we get user-visible differences in error -- messages, which are confusing. If you want to see @@ -520,8 +517,8 @@ writeMetaTyVar tyvar ty do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar ) ; writeMutVar (metaTvRef tyvar) (Indirect ty) } where - k1 = tyVarKind tyvar - k2 = typeKind ty + _k1 = tyVarKind tyvar + _k2 = typeKind ty \end{code} @@ -713,11 +710,6 @@ zonkTcType ty = zonkType (\ tv -> return (TyVarTy tv)) ty zonkTcTypes :: [TcType] -> TcM [TcType] zonkTcTypes tys = mapM zonkTcType tys -zonkTcClassConstraints cts = mapM zonk cts - where zonk (clas, tys) = do - new_tys <- zonkTcTypes tys - return (clas, new_tys) - zonkTcThetaType :: TcThetaType -> TcM TcThetaType zonkTcThetaType theta = mapM zonkTcPredType theta @@ -1024,12 +1016,12 @@ checkValidType ctxt ty = do actual_kind = typeKind ty kind_ok = case ctxt of - TySynCtxt _ -> True -- Any kind will do - ResSigCtxt -> isSubOpenTypeKind actual_kind - ExprSigCtxt -> isSubOpenTypeKind actual_kind + TySynCtxt _ -> True -- Any kind will do + ResSigCtxt -> isSubOpenTypeKind actual_kind + ExprSigCtxt -> isSubOpenTypeKind actual_kind GenPatCtxt -> isLiftedTypeKind actual_kind ForSigCtxt _ -> isLiftedTypeKind actual_kind - other -> isSubArgTypeKind actual_kind + _ -> isSubArgTypeKind actual_kind ubx_tup = case ctxt of TySynCtxt _ | unboxed -> UT_Ok @@ -1094,16 +1086,16 @@ check_type rank ubx_tup ty -- {-# 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 rank ubx_tup (PredTy sty) +check_type _ _ (PredTy sty) = do { dflags <- getDOpts ; check_pred_ty dflags TypeCtxt sty } -check_type rank ubx_tup (TyVarTy _) = return () -check_type rank ubx_tup ty@(FunTy arg_ty res_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 } -check_type rank ubx_tup (AppTy ty1 ty2) +check_type rank _ (AppTy ty1 ty2) = do { check_arg_type rank ty1 ; check_arg_type rank ty2 } @@ -1144,7 +1136,9 @@ check_type rank ubx_tup ty@(TyConApp tc tys) = mapM_ (check_arg_type rank) tys where - ubx_tup_ok ub_tuples_allowed = case ubx_tup of { UT_Ok -> ub_tuples_allowed; other -> False } + ubx_tup_ok ub_tuples_allowed = case ubx_tup of + UT_Ok -> ub_tuples_allowed + _ -> False n_args = length tys tc_arity = tyConArity tc @@ -1152,6 +1146,8 @@ check_type rank ubx_tup ty@(TyConApp tc tys) arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args ubx_tup_msg = ubxArgTyErr ty +check_type _ _ ty = pprPanic "check_type" (ppr ty) + ---------------------------------------- check_arg_type :: Rank -> Type -> TcM () -- The sort of type that can instantiate a type variable, @@ -1179,10 +1175,13 @@ check_arg_type rank ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } ---------------------------------------- -forAllTyErr ty = sep [ptext SLIT("Illegal polymorphic or qualified type:"), ppr ty] -unliftedArgErr ty = sep [ptext SLIT("Illegal unlifted type:"), ppr ty] -ubxArgTyErr ty = sep [ptext SLIT("Illegal unboxed tuple type as function argument:"), ppr ty] -kindErr kind = sep [ptext SLIT("Expecting an ordinary type, but found a type of kind"), ppr kind] +forAllTyErr, unliftedArgErr, ubxArgTyErr :: Type -> SDoc +forAllTyErr ty = sep [ptext (sLit "Illegal polymorphic or qualified type:"), ppr ty] +unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty] +ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr ty] + +kindErr :: Kind -> SDoc +kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind] \end{code} Note [Liberal type synonyms] @@ -1239,11 +1238,12 @@ data SourceTyCtxt | InstThetaCtxt -- Context of an instance decl -- instance => C [a] where ... -pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c) -pprSourceTyCtxt SigmaCtxt = ptext SLIT("the context of a polymorphic type") -pprSourceTyCtxt (DataTyCtxt tc) = ptext SLIT("the context of the data type declaration for") <+> quotes (ppr tc) -pprSourceTyCtxt InstThetaCtxt = ptext SLIT("the context of an instance declaration") -pprSourceTyCtxt TypeCtxt = ptext SLIT("the context of a type") +pprSourceTyCtxt :: SourceTyCtxt -> SDoc +pprSourceTyCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) +pprSourceTyCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") +pprSourceTyCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) +pprSourceTyCtxt InstThetaCtxt = ptext (sLit "the context of an instance declaration") +pprSourceTyCtxt TypeCtxt = ptext (sLit "the context of a type") \end{code} \begin{code} @@ -1252,7 +1252,8 @@ checkValidTheta ctxt theta = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) ------------------------- -check_valid_theta ctxt [] +check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM () +check_valid_theta _ [] = return () check_valid_theta ctxt theta = do dflags <- getDOpts @@ -1277,9 +1278,9 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) arity = classArity cls n_tys = length tys arity_err = arityErr "Class" class_name arity n_tys - how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this")) + how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this")) -check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) +check_pred_ty dflags _ pred@(EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (dopt Opt_TypeFamilies dflags) (eqPredTyErr pred) @@ -1289,7 +1290,7 @@ check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) ; check_mono_type ty2 } -check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_mono_type ty +check_pred_ty _ SigmaCtxt (IParam _ ty) = check_mono_type ty -- Implicit parameters only allowed in type -- signatures; not in instance decls, superclasses etc -- The reason for not allowing implicit params in instances is a bit @@ -1301,7 +1302,7 @@ check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_mono_type ty -- instance decl would show up two uses of ?x. -- Catch-all -check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty) +check_pred_ty _ _ sty = failWithTc (badPredTyErr sty) ------------------------- check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool @@ -1311,12 +1312,13 @@ check_class_pred_tys dflags ctxt tys InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys -- Further checks on head and theta in -- checkInstTermination - other -> flexible_contexts || all tyvar_head tys + _ -> flexible_contexts || all tyvar_head tys where flexible_contexts = dopt Opt_FlexibleContexts dflags undecidable_ok = dopt Opt_UndecidableInstances dflags ------------------------- +tyvar_head :: Type -> Bool tyvar_head ty -- Haskell 98 allows predicates of form | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) | otherwise -- where a is a type variable @@ -1371,10 +1373,11 @@ checkAmbiguity forall_tyvars theta tau_tyvars ambig_var ct_var = (ct_var `elem` forall_tyvars) && not (ct_var `elemVarSet` extended_tau_vars) +ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred), - nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$ - ptext SLIT("must be reachable from the type after the '=>'"))] + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred), + nest 4 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ + ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} In addition, GHC insists that at least one type variable @@ -1383,6 +1386,7 @@ in each constraint is in V. So we disallow a type like even in a scope where b is in scope. \begin{code} +checkFreeness :: [Var] -> [PredType] -> TcM () checkFreeness forall_tyvars theta = do { flexible_contexts <- doptM Opt_FlexibleContexts ; unless flexible_contexts $ mapM_ complain (filter is_free theta) } @@ -1392,50 +1396,57 @@ checkFreeness forall_tyvars theta bound_var ct_var = ct_var `elem` forall_tyvars complain pred = addErrTc (freeErr pred) +freeErr :: PredType -> SDoc freeErr pred - = sep [ ptext SLIT("All of the type variables in the constraint") <+> + = sep [ ptext (sLit "All of the type variables in the constraint") <+> quotes (pprPred pred) - , ptext SLIT("are already in scope") <+> - ptext SLIT("(at least one must be universally quantified here)") + , ptext (sLit "are already in scope") <+> + ptext (sLit "(at least one must be universally quantified here)") , nest 4 $ - ptext SLIT("(Use -XFlexibleContexts to lift this restriction)") + ptext (sLit "(Use -XFlexibleContexts to lift this restriction)") ] \end{code} \begin{code} +checkThetaCtxt :: SourceTyCtxt -> ThetaType -> SDoc checkThetaCtxt ctxt theta - = vcat [ptext SLIT("In the context:") <+> pprTheta theta, - ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ] + = vcat [ptext (sLit "In the context:") <+> pprTheta theta, + ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ] -badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty -eqPredTyErr sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty +badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc +badPredTyErr sty = ptext (sLit "Illegal constraint") <+> pprPred sty +eqPredTyErr sty = ptext (sLit "Illegal equational constraint") <+> pprPred sty $$ - parens (ptext SLIT("Use -XTypeFamilies to permit this")) -predTyVarErr pred = sep [ptext SLIT("Non type-variable argument"), - nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)] -dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) + parens (ptext (sLit "Use -XTypeFamilies to permit this")) +predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), + nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] +dupPredWarn :: [[PredType]] -> SDoc +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) +arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m - = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"), + = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"), n_arguments <> comma, text "but has been given", int m] where - n_arguments | n == 0 = ptext SLIT("no arguments") - | n == 1 = ptext SLIT("1 argument") - | True = hsep [int n, ptext SLIT("arguments")] + n_arguments | n == 0 = ptext (sLit "no arguments") + | n == 1 = ptext (sLit "1 argument") + | True = hsep [int n, ptext (sLit "arguments")] ----------------- +notMonoType :: TcType -> TcM a notMonoType ty = do { ty' <- zonkTcType ty ; env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 ty' - msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty) + msg = ptext (sLit "Cannot match a monotype with") <+> quotes (ppr tidy_ty) ; failWithTcM (env1, msg) } +notMonoArgs :: TcType -> TcM a notMonoArgs ty = do { ty' <- zonkTcType ty ; env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 ty' - msg = ptext SLIT("Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty) + msg = ptext (sLit "Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty) ; failWithTcM (env1, msg) } \end{code} @@ -1473,6 +1484,7 @@ checkValidInstHead ty -- Should be a source type return (clas, tys) }} +check_inst_head :: DynFlags -> Class -> [Type] -> TcM () check_inst_head dflags clas tys -- If GlasgowExts then check at least one isn't a type variable = do checkTc (dopt Opt_TypeSynonymInstances dflags || @@ -1507,8 +1519,9 @@ check_inst_head dflags clas tys text "Only one type can be given in an instance head." $$ text "Use -XMultiParamTypeClasses if you want to allow more.") +instTypeErr :: SDoc -> SDoc -> SDoc instTypeErr pp_ty msg - = sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty, + = sep [ptext (sLit "Illegal instance declaration for") <+> quotes pp_ty, nest 4 msg] \end{code} @@ -1539,7 +1552,7 @@ checkValidInstance tyvars theta clas inst_tys (instTypeErr (pprClassPred clas inst_tys) msg) } where - msg = parens (vcat [ptext SLIT("the Coverage Condition fails for one of the functional dependencies;"), + msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) \end{code} @@ -1575,12 +1588,14 @@ checkInstTermination tys theta | otherwise = Nothing +predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] -nomoreMsg = ptext SLIT("Variable occurs more often in a constraint than in the instance head") -smallerMsg = ptext SLIT("Constraint is no smaller than the instance head") -undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this") +nomoreMsg, smallerMsg, undecidableMsg :: SDoc +nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head") +smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") +undecidableMsg = ptext (sLit "Use -fallow-undecidable-instances to permit this") \end{code} @@ -1644,9 +1659,9 @@ Allow constraints which consist only of type variables, with no repeats. \begin{code} validDerivPred :: PredType -> Bool -validDerivPred (ClassP cls tys) = hasNoDups fvs && sizeTypes tys == length fvs - where fvs = fvTypes tys -validDerivPred otehr = False +validDerivPred (ClassP _ tys) = hasNoDups fvs && sizeTypes tys == length fvs + where fvs = fvTypes tys +validDerivPred _ = False \end{code} %************************************************************************ @@ -1714,23 +1729,27 @@ isTyFamFree = null . tyFamInsts -- Error messages +tyFamInstInIndexErr :: Type -> SDoc tyFamInstInIndexErr ty - = hang (ptext SLIT("Illegal type family application in type instance") <> + = hang (ptext (sLit "Illegal type family application in type instance") <> colon) 4 $ ppr ty +polyTyErr :: Type -> SDoc polyTyErr ty - = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $ + = hang (ptext (sLit "Illegal polymorphic type in type instance") <> colon) 4 $ ppr ty +famInstUndecErr :: Type -> SDoc -> SDoc famInstUndecErr ty msg = sep [msg, - nest 2 (ptext SLIT("in the type family application:") <+> + nest 2 (ptext (sLit "in the type family application:") <+> pprType ty)] -nestedMsg = ptext SLIT("Nested type family application") -nomoreVarMsg = ptext SLIT("Variable occurs more often than in instance head") -smallerAppMsg = ptext SLIT("Application is no smaller than the instance head") +nestedMsg, nomoreVarMsg, smallerAppMsg :: SDoc +nestedMsg = ptext (sLit "Nested type family application") +nomoreVarMsg = ptext (sLit "Variable occurs more often than in instance head") +smallerAppMsg = ptext (sLit "Application is no smaller than the instance head") \end{code}