X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=243fc853d5bb93d87ccec9cdb0b7eb401623bb0a;hb=bd8a952b1ec55c1c8fe6db968f8f0cc08596a550;hp=b9db015e1dafc4ad612848a0aa4289e6e798f0b5;hpb=a162b85d26966ba0eecc4d2ae02d4fd71f5cb9f8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index b9db015..243fc85 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, @@ -40,25 +33,26 @@ module TcMType ( -------------------------------- -- Instantiation tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar, - tcInstSigTyVars, - tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType, - tcSkolSigType, tcSkolSigTyVars, occurCheckErr, + tcInstType, tcInstSigType, + tcInstSkolTyVars, tcInstSkolType, + tcSkolSigType, tcSkolSigTyVars, occurCheckErr, execTcTyVarBinds, -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, checkValidInstance, - checkInstTermination, checkValidTypeInst, checkTyFamFreeness, + checkInstTermination, checkValidTypeInst, checkTyFamFreeness, checkKinds, checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt, unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs, + growPredTyVars, growTyVars, growThetaTyVars, -------------------------------- -- Zonking zonkType, zonkTcPredType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, - zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKindToKind, zonkTcKind, zonkTopTyVar, readKindVar, writeKindVar @@ -76,13 +70,16 @@ import TyCon import Var -- others: -import TcRnMonad -- TcType, amongst others +import HsSyn -- HsType +import TcRnMonad -- TcType, amongst others import FunDeps import Name +import VarEnv import VarSet import ErrUtils import DynFlags import Util +import Bag import Maybes import ListSetOps import UniqSupply @@ -90,7 +87,7 @@ import SrcLoc import Outputable import FastString -import Control.Monad ( when, unless ) +import Control.Monad import Data.List ( (\\) ) \end{code} @@ -160,6 +157,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 @@ -184,7 +182,7 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) -- (checkTauTvUpdate tv ty) -- We are about to update the TauTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that ty is a monotype +-- (b) that ty is a monotype -- Furthermore, in the interest of (b), if you find an -- empty box (BoxTv that is Flexi), fill it in with a TauTv -- @@ -223,7 +221,7 @@ checkTauTvUpdate orig_tv orig_ty | isSynTyCon tc = go_syn tc tys | otherwise = do { tys' <- mapM go tys ; return $ occurs (TyConApp tc) tys' } - go (PredTy p) = do { p' <- go_pred p + go (PredTy p) = do { p' <- go_pred p ; return $ occurs1 PredTy p' } go (FunTy arg res) = do { arg' <- go arg ; res' <- go res @@ -234,7 +232,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 +257,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 +266,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 @@ -341,25 +339,48 @@ Rather, we should bind t to () (= non_var_ty2). -------------- +Execute a bag of type variable bindings. + +\begin{code} +execTcTyVarBinds :: TcTyVarBinds -> TcM () +execTcTyVarBinds = mapM_ execTcTyVarBind . bagToList + where + execTcTyVarBind (TcTyVarBind tv ty) + = do { ASSERTM2( do { details <- readMetaTyVar tv + ; return (isFlexi details) }, ppr tv ) + ; ty' <- if isCoVar tv + then return ty + else do { maybe_ty <- checkTauTvUpdate tv ty + ; case maybe_ty of + Nothing -> pprPanic "TcRnMonad.execTcTyBind" + (ppr tv <+> text ":=" <+> ppr ty) + Just ty' -> return ty' + } + ; writeMetaTyVar tv ty' + } +\end{code} + 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 +403,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 +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] } @@ -433,17 +454,17 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar] tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info | tv <- tyvars ] -tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar +tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar -- Instantiate the tyvar, using -- * the occ-name and kind of the supplied tyvar, -- * the unique from the monad, -- * the location either from the tyvar (mb_loc = Nothing) -- or from mb_loc (Just loc) -tcInstSkolTyVar info mb_loc tyvar +tcInstSkolTyVar info get_loc tyvar = do { uniq <- newUnique ; let old_name = tyVarName tyvar kind = tyVarKind tyvar - loc = mb_loc `orElse` getSrcSpan old_name + loc = get_loc old_name new_name = mkInternalName uniq (nameOccName old_name) loc ; return (mkSkolTyVar new_name kind info) } @@ -451,12 +472,21 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar] -- Get the location from the monad tcInstSkolTyVars info tyvars = do { span <- getSrcSpanM - ; mapM (tcInstSkolTyVar info (Just span)) tyvars } + ; mapM (tcInstSkolTyVar info (const span)) tyvars } tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants -- Binding location comes from the monad tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty + +tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType) +-- Instantiate with skolems or meta SigTvs; depending on use_skols +-- Always take location info from the supplied tyvars +tcInstSigType use_skols skol_info ty + = tcInstType (mapM inst_tyvar) ty + where + inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan + | otherwise = instMetaTyVar (SigTv skol_info) \end{code} @@ -474,9 +504,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 @@ -515,13 +545,17 @@ writeMetaTyVar tyvar ty return () | otherwise = ASSERT( isMetaTyVar tyvar ) - -- TOM: It should also work for coercions - -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) ) - do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar ) + ASSERT2( isCoVar tyvar || typeKind ty `isSubKind` tyVarKind tyvar, + (ppr tyvar <+> ppr (tyVarKind tyvar)) + $$ (ppr ty <+> ppr (typeKind ty)) ) + do { if debugIsOn then do { details <- readMetaTyVar tyvar; +-- FIXME ; ASSERT2( not (isFlexi details), ppr tyvar ) + ; WARN( not (isFlexi details), ppr tyvar ) + return () } + else return () + + ; traceTc (text "writeMetaTyVar" <+> ppr tyvar <+> text ":=" <+> ppr ty) ; writeMutVar (metaTvRef tyvar) (Indirect ty) } - where - k1 = tyVarKind tyvar - k2 = typeKind ty \end{code} @@ -566,16 +600,6 @@ tcInstTyVars tyvars %************************************************************************ \begin{code} -tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar] --- Instantiate with skolems or meta SigTvs; depending on use_skols --- Always take location info from the supplied tyvars -tcInstSigTyVars use_skols skol_info tyvars - | use_skols - = mapM (tcInstSkolTyVar skol_info Nothing) tyvars - - | otherwise - = mapM (instMetaTyVar (SigTv skol_info)) tyvars - zonkSigTyVar :: TcTyVar -> TcM TcTyVar zonkSigTyVar sig_tv | isSkolemTyVar sig_tv @@ -713,11 +737,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 @@ -771,8 +790,11 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- -- We leave skolem TyVars alone; they are immutable. zonkQuantifiedTyVar tv - | ASSERT( isTcTyVar tv ) - isSkolemTyVar tv = return tv + | ASSERT2( isTcTyVar tv, ppr tv ) + isSkolemTyVar tv + = do { kind <- zonkTcType (tyVarKind tv) + ; return $ setTyVarKind tv kind + } -- It might be a skolem type variable, -- for example from a user type signature @@ -819,7 +841,7 @@ Consider this: * Now abstract over the 'a', but float out the Num (C d a) constraint because it does not 'really' mention a. (see exactTyVarsOfType) The arg to foo becomes - /\a -> \t -> t+t + \/\a -> \t -> t+t * So we get a dict binding for Num (C d a), which is zonked to give a = () @@ -828,10 +850,10 @@ Consider this: quantification, so the floated dict will still have type (C d a). Which renders this whole note moot; happily!] -* Then the /\a abstraction has a zonked 'a' in it. +* Then the \/\a abstraction has a zonked 'a' in it. All very silly. I think its harmless to ignore the problem. We'll end up with -a /\a in the final result but all the occurrences of a will be zonked to () +a \/\a in the final result but all the occurrences of a will be zonked to () Note [Zonking to Skolem] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -904,12 +926,14 @@ zonkType unbound_var_fn ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar unbound_var_fn tyvar - | otherwise = return (TyVarTy tyvar) + | otherwise = liftM TyVarTy $ + zonkTyVar unbound_var_fn tyvar -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - return (ForAllTy tyvar ty') + tyvar' <- zonkTyVar unbound_var_fn tyvar + return (ForAllTy tyvar' ty') go_pred (ClassP c tys) = do tys' <- mapM go tys return (ClassP c tys') @@ -919,17 +943,29 @@ zonkType unbound_var_fn ty ty2' <- go ty2 return (EqPred ty1' ty2') -zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable +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). +-- +zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable var + -> TyVar -> TcM TyVar +zonkTyVar unbound_var_fn tv + | isCoVar tv + = do { kind <- zonkType unbound_var_fn (tyVarKind tv) + ; return $ setTyVarKind tv kind + } + | otherwise = return tv \end{code} @@ -1001,78 +1037,93 @@ checkValidType ctxt ty = do rankn <- doptM Opt_RankNTypes polycomp <- doptM Opt_PolymorphicComponents let - rank | rankn = Arbitrary - | rank2 = Rank 2 - | otherwise - = case ctxt of -- Haskell 98 - GenPatCtxt -> Rank 0 - LamPatSigCtxt -> Rank 0 - BindPatSigCtxt -> Rank 0 - DefaultDeclCtxt-> Rank 0 - ResSigCtxt -> Rank 0 - TySynCtxt _ -> Rank 0 - ExprSigCtxt -> Rank 1 - FunSigCtxt _ -> Rank 1 - ConArgCtxt _ -> if polycomp - then Rank 2 + gen_rank n | rankn = ArbitraryRank + | rank2 = Rank 2 + | otherwise = Rank n + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + LamPatSigCtxt -> gen_rank 0 + BindPatSigCtxt -> gen_rank 0 + TySynCtxt _ -> gen_rank 0 + GenPatCtxt -> gen_rank 1 + -- This one is a bit of a hack + -- See the forall-wrapping in TcClassDcl.mkGenericInstance + + ExprSigCtxt -> gen_rank 1 + FunSigCtxt _ -> gen_rank 1 + ConArgCtxt _ | polycomp -> gen_rank 2 -- We are given the type of the entire -- constructor, hence rank 1 - else Rank 1 - ForSigCtxt _ -> Rank 1 - SpecInstCtxt -> Rank 1 + | otherwise -> gen_rank 1 + + ForSigCtxt _ -> gen_rank 1 + SpecInstCtxt -> gen_rank 1 + ThBrackCtxt -> gen_rank 1 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 + ThBrackCtxt -> 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 ExprSigCtxt | unboxed -> UT_Ok + 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 () -checkValidMonoType ty = check_mono_type ty +checkValidMonoType ty = check_mono_type MustBeMonoType ty \end{code} \begin{code} -data Rank = Rank Int | Arbitrary +data Rank = ArbitraryRank -- Any rank ok + | MustBeMonoType -- Monotype regardless of flags + | TyConArgMonoType -- Monotype but could be poly if -XImpredicativeTypes + | SynArgMonoType -- Monotype but could be poly if -XLiberalTypeSynonyms + | Rank Int -- Rank n, but could be more with -XRankNTypes -decRank :: Rank -> Rank -decRank Arbitrary = Arbitrary -decRank (Rank n) = Rank (n-1) +decRank :: Rank -> Rank -- Function arguments +decRank (Rank 0) = Rank 0 +decRank (Rank n) = Rank (n-1) +decRank other_rank = other_rank nonZeroRank :: Rank -> Bool -nonZeroRank (Rank 0) = False -nonZeroRank _ = True +nonZeroRank ArbitraryRank = True +nonZeroRank (Rank n) = n>0 +nonZeroRank _ = False ---------------------------------------- data UbxTupFlag = UT_Ok | UT_NotOk - -- The "Ok" version means "ok if -fglasgow-exts is on" + -- The "Ok" version means "ok if UnboxedTuples is on" ---------------------------------------- -check_mono_type :: Type -> TcM () -- No foralls anywhere - -- No unlifted types of any kind -check_mono_type ty - = do { check_type (Rank 0) UT_NotOk ty +check_mono_type :: Rank -> Type -> TcM () -- No foralls anywhere + -- No unlifted types of any kind +check_mono_type rank ty + = do { check_type rank UT_NotOk ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } check_type :: Rank -> UbxTupFlag -> Type -> TcM () --- The args say what the *type* context requires, independent +-- The args say what the *type context* requires, independent -- of *flag* settings. You test the flag settings at usage sites. -- -- Rank is allowed rank for function args @@ -1080,7 +1131,7 @@ check_type :: Rank -> UbxTupFlag -> Type -> TcM () check_type rank ubx_tup ty | not (null tvs && null theta) - = do { checkTc (nonZeroRank rank) (forAllTyErr ty) + = do { checkTc (nonZeroRank rank) (forAllTyErr rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message ; check_valid_theta SigmaCtxt theta @@ -1090,20 +1141,17 @@ 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 rank ubx_tup (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) +-- 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 } -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 } @@ -1121,7 +1169,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) ; liberal <- doptM Opt_LiberalTypeSynonyms ; if not liberal || isOpenSynTyCon tc then -- For H98 and synonym families, do check the type args - mapM_ check_mono_type tys + mapM_ (check_mono_type SynArgMonoType) tys else -- In the liberal case (only for closed syns), expand then check case tcView ty of @@ -1134,7 +1182,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg ; impred <- doptM Opt_ImpredicativeTypes - ; let rank' = if impred then rank else Rank 0 + ; let rank' = if impred then ArbitraryRank else TyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty @@ -1144,7 +1192,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 +1202,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, @@ -1174,15 +1226,36 @@ check_arg_type :: Rank -> Type -> TcM () check_arg_type rank ty = do { impred <- doptM Opt_ImpredicativeTypes - ; let rank' = if impred then rank else Rank 0 -- Monotype unless impredicative + ; let rank' = case rank of -- Predictive => must be monotype + MustBeMonoType -> MustBeMonoType -- Monotype, regardless + _other | impred -> ArbitraryRank + | otherwise -> TyConArgMonoType + -- Make sure that MustBeMonoType is propagated, + -- so that we don't suggest -XImpredicativeTypes in + -- (Ord (forall a.a)) => a -> a + -- and so that if it Must be a monotype, we check that it is! + ; check_type rank' UT_NotOk 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 :: Rank -> Type -> SDoc +forAllTyErr rank ty + = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty) + , suggestion ] + where + suggestion = case rank of + Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types") + TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes") + SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms") + _ -> empty -- Polytype is always illegal + +unliftedArgErr, ubxArgTyErr :: Type -> SDoc +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 +1312,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 +1326,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 @@ -1268,7 +1343,7 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) ; checkTc (arity == n_tys) arity_err -- Check the form of the argument types - ; mapM_ check_mono_type tys + ; mapM_ checkValidMonoType tys ; checkTc (check_class_pred_tys dflags ctxt tys) (predTyVarErr pred $$ how_to_allow) } @@ -1277,19 +1352,27 @@ 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 _ (ClassSCCtxt _) (EqPred _ _) + = -- We do not yet support superclass equalities. + failWithTc $ + sep [ ptext (sLit "The current implementation of type families does not") + , ptext (sLit "support equality constraints in superclass contexts.") + , ptext (sLit "They are planned for a future release.") + ] -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) -- Check the form of the argument types - ; check_mono_type ty1 - ; check_mono_type ty2 + ; checkValidMonoType ty1 + ; checkValidMonoType ty2 } -check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_mono_type ty +check_pred_ty _ SigmaCtxt (IParam _ ty) = checkValidMonoType 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 +1384,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 +1394,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 @@ -1362,7 +1446,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars = mapM_ complain (filter is_ambig theta) where complain pred = addErrTc (ambigErr pred) - extended_tau_vars = grow theta tau_tyvars + extended_tau_vars = growThetaTyVars theta tau_tyvars -- See Note [Implicit parameters and ambiguity] in TcSimplify is_ambig pred = isClassPred pred && @@ -1371,10 +1455,33 @@ 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 '=>'"))] + +-------------------------- +-- For this 'grow' stuff see Note [Growing the tau-tvs using constraints] in Inst + +growThetaTyVars :: TcThetaType -> TyVarSet -> TyVarSet +-- Finds a fixpoint +growThetaTyVars theta tvs + | null theta = tvs + | otherwise = fixVarSet mk_next tvs + where + mk_next tvs = foldr growPredTyVars tvs theta + + +growPredTyVars :: TcPredType -> TyVarSet -> TyVarSet +-- Here is where the special case for inplicit parameters happens +growPredTyVars (IParam _ ty) tvs = tvs `unionVarSet` tyVarsOfType ty +growPredTyVars pred tvs = growTyVars (tyVarsOfPred pred) tvs + +growTyVars :: TyVarSet -> TyVarSet -> TyVarSet +growTyVars new_tvs tvs + | new_tvs `intersectsVarSet` tvs = tvs `unionVarSet` new_tvs + | otherwise = tvs \end{code} In addition, GHC insists that at least one type variable @@ -1383,6 +1490,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 +1500,58 @@ 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"), - n_arguments <> comma, text "but has been given", int m] + = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"), + 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") - | 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} @@ -1468,28 +1584,32 @@ checkValidInstHead ty -- Should be a source type Just (clas,tys) -> do dflags <- getDOpts - mapM_ check_mono_type tys check_inst_head dflags clas tys 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 || - all tcInstHeadTyNotSynonym tys) - (instTypeErr (pprClassPred clas tys) head_type_synonym_msg) - checkTc (dopt Opt_FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars tys) - (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg) - checkTc (dopt Opt_MultiParamTypeClasses dflags || - isSingleton tys) - (instTypeErr (pprClassPred clas tys) head_one_type_msg) - mapM_ check_mono_type tys + = do { -- If GlasgowExts then check at least one isn't a type variable + ; checkTc (dopt Opt_TypeSynonymInstances dflags || + all tcInstHeadTyNotSynonym tys) + (instTypeErr (pprClassPred clas tys) head_type_synonym_msg) + ; checkTc (dopt Opt_FlexibleInstances dflags || + all tcInstHeadTyAppAllTyVars tys) + (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg) + ; checkTc (dopt Opt_MultiParamTypeClasses dflags || + isSingleton tys) + (instTypeErr (pprClassPred clas tys) head_one_type_msg) + -- May not contain type family applications + ; mapM_ checkTyFamFreeness tys + + ; mapM_ checkValidMonoType tys -- For now, I only allow tau-types (not polytypes) in -- the head of an instance decl. -- E.g. instance C (forall a. a->a) is rejected -- One could imagine generalising that, but I'm not sure -- what all the consequences might be + } where head_type_synonym_msg = parens ( @@ -1507,8 +1627,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} @@ -1519,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) @@ -1537,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;"), + 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 @@ -1575,12 +1707,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 -XUndecidableInstances to permit this") \end{code} @@ -1606,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. @@ -1620,7 +1753,7 @@ should have only type-variable constraints. Here is another example: data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -fallow-undecidable-instances we +Here, if we are prepared to allow -XUndecidableInstances we could derive the instance instance Eq (f (Fix f)) => Eq (Fix f) but this is so delicate that I don't think it should happen inside @@ -1644,9 +1777,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} %************************************************************************ @@ -1657,7 +1790,7 @@ validDerivPred otehr = False \begin{code} -- Check that a "type instance" is well-formed (which includes decidability --- unless -fallow-undecidable-instances is given). +-- unless -XUndecidableInstances is given). -- checkValidTypeInst :: [Type] -> Type -> TcM () checkValidTypeInst typats rhs @@ -1666,8 +1799,7 @@ checkValidTypeInst typats rhs ; mapM_ checkTyFamFreeness typats -- the right-hand side is a tau type - ; checkTc (isTauTy rhs) $ - polyTyErr rhs + ; checkValidMonoType rhs -- we have a decidable instance unless otherwise permitted ; undecidable_ok <- doptM Opt_UndecidableInstances @@ -1705,7 +1837,7 @@ checkFamInst lhsTys famInsts checkTyFamFreeness :: Type -> TcM () checkTyFamFreeness ty = checkTc (isTyFamFree ty) $ - tyFamInstInIndexErr ty + tyFamInstIllegalErr ty -- Check that a type does not contain any type family applications. -- @@ -1714,23 +1846,22 @@ isTyFamFree = null . tyFamInsts -- Error messages -tyFamInstInIndexErr ty - = hang (ptext SLIT("Illegal type family application in type instance") <> +tyFamInstIllegalErr :: Type -> SDoc +tyFamInstIllegalErr ty + = hang (ptext (sLit "Illegal type synonym family application in instance") <> colon) 4 $ ppr ty -polyTyErr ty - = 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} @@ -1772,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}