tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
tcInstSigType,
tcInstSkolTyVars, tcInstSkolType,
- tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
+ 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
import ErrUtils
import DynFlags
import Util
+import Bag
import Maybes
import ListSetOps
import UniqSupply
--------------
+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}
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}
--
-- 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
-- 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')
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
; case cts of
Flexi -> unbound_var_fn tyvar -- Unbound meta type variable
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}
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 -- Function arguments
; liberal <- doptM Opt_LiberalTypeSynonyms
; if not liberal || isOpenSynTyCon tc then
-- For H98 and synonym families, do check the type args
- mapM_ (check_mono_type TyConArgMonoType) tys
+ mapM_ (check_mono_type SynArgMonoType) tys
else -- In the liberal case (only for closed syns), expand then check
case tcView ty of
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
arity_err = arityErr "Class" class_name arity n_tys
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 _ pred@(EqPred ty1 ty2)
= do { -- Equational constraints are valid in all contexts if type
-- families are permitted
= 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 &&
= 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
projects / ghc-hetmet.git / blobdiff