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,
zonkType, zonkTcPredType,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
zonkQuantifiedTyVar, zonkQuantifiedTyVars,
- zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
+ zonkTcType, zonkTcTypes, zonkTcThetaType,
zonkTcKindToKind, zonkTcKind, zonkTopTyVar,
readKindVar, writeKindVar
import TcRnMonad -- TcType, amongst others
import FunDeps
import Name
+import VarEnv
import VarSet
import ErrUtils
import DynFlags
import UniqSupply
import SrcLoc
import Outputable
+import FastString
-import Control.Monad ( when, unless )
+import Control.Monad
import Data.List ( (\\) )
\end{code}
}
----------------
+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
-- its kind has as much boxity information visible as possible.
- | tk2 `isSubKind` tk1 = returnM ()
+ | tk2 `isSubKind` tk1 = return ()
| otherwise
-- Either the kinds aren't compatible
-- closed type synonym that expands to a tau type.
go (TyConApp tc tys)
| isSynTyCon tc = go_syn tc tys
- | otherwise = do { tys' <- mappM go tys
+ | otherwise = do { tys' <- mapM go tys
; return $ occurs (TyConApp tc) tys' }
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
go (PredTy p) = do { p' <- go_pred p
; return $ occurs1 PredTy p' }
go (FunTy arg res) = do { arg' <- go arg
-- 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)
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
| 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
Error mesages in case of kind mismatch.
\begin{code}
-unifyKindMisMatch ty1 ty2
- = zonkTcKind ty1 `thenM` \ ty1' ->
- zonkTcKind ty2 `thenM` \ ty2' ->
+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')])
- in
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
- = returnM msg
+ = 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)
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}
%************************************************************************
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] }
; return (mkTyVarTy (mkKindVar uniq ref)) }
newKindVars :: Int -> TcM [TcKind]
-newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
+newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())
\end{code}
; 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
| otherwise = return False
writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
-#ifndef DEBUG
-writeMetaTyVar tyvar ty = writeMutVar (metaTvRef tyvar) (Indirect ty)
-#else
+writeMetaTyVar tyvar ty
+ | not debugIsOn = writeMutVar (metaTvRef tyvar) (Indirect ty)
writeMetaTyVar tyvar ty
| not (isMetaTyVar tyvar)
= pprTrace "writeMetaTyVar" (ppr tyvar) $
- returnM ()
-
+ return ()
| otherwise
= ASSERT( isMetaTyVar tyvar )
-- TOM: It should also work for coercions
do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
; writeMutVar (metaTvRef tyvar) (Indirect ty) }
where
- k1 = tyVarKind tyvar
- k2 = typeKind ty
-#endif
+ _k1 = tyVarKind tyvar
+ _k2 = typeKind ty
\end{code}
newFlexiTyVar kind = newMetaTyVar TauTv kind
newFlexiTyVarTy :: Kind -> TcM TcType
-newFlexiTyVarTy kind
- = newFlexiTyVar kind `thenM` \ tc_tyvar ->
- returnM (TyVarTy tc_tyvar)
+newFlexiTyVarTy kind = do
+ tc_tyvar <- newFlexiTyVar kind
+ return (TyVarTy tc_tyvar)
newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
-newFlexiTyVarTys n kind = mappM newFlexiTyVarTy (nOfThem n kind)
+newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
tcInstTyVar :: TyVar -> TcM TcTyVar
-- Instantiate with a META type variable
tcInstTyVars tyvars
= do { tc_tvs <- mapM tcInstTyVar tyvars
; let tys = mkTyVarTys tc_tvs
- ; returnM (tc_tvs, tys, zipTopTvSubst tyvars tys) }
+ ; return (tc_tvs, tys, zipTopTvSubst tyvars tys) }
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
-- any existing for-alls. Hence zipTopTvSubst
getTcTyVar tyvar
| not (isTcTyVar tyvar)
= pprTrace "getTcTyVar" (ppr tyvar) $
- returnM (Just (mkTyVarTy tyvar))
+ return (Just (mkTyVarTy tyvar))
| otherwise
- = ASSERT2( isTcTyVar tyvar, ppr tyvar )
- readMetaTyVar tyvar `thenM` \ maybe_ty ->
+ = ASSERT2( isTcTyVar tyvar, ppr tyvar ) do
+ maybe_ty <- readMetaTyVar tyvar
case maybe_ty of
- Just ty -> short_out ty `thenM` \ ty' ->
- writeMetaTyVar tyvar (Just ty') `thenM_`
- returnM (Just ty')
+ Just ty -> do ty' <- short_out ty
+ writeMetaTyVar tyvar (Just ty')
+ return (Just ty')
- Nothing -> returnM Nothing
+ Nothing -> return Nothing
short_out :: TcType -> TcM TcType
short_out ty@(TyVarTy tyvar)
| not (isTcTyVar tyvar)
- = returnM ty
+ = return ty
- | otherwise
- = readMetaTyVar tyvar `thenM` \ maybe_ty ->
+ | otherwise = do
+ maybe_ty <- readMetaTyVar tyvar
case maybe_ty of
- Just ty' -> short_out ty' `thenM` \ ty' ->
- writeMetaTyVar tyvar (Just ty') `thenM_`
- returnM ty'
+ Just ty' -> do ty' <- short_out ty'
+ writeMetaTyVar tyvar (Just ty')
+ return ty'
- other -> returnM ty
+ other -> return ty
-short_out other_ty = returnM other_ty
+short_out other_ty = return other_ty
-}
\end{code}
\begin{code}
zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
-zonkTcTyVars tyvars = mappM zonkTcTyVar tyvars
+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
zonkTcTyVarsAndFV :: [TcTyVar] -> TcM TcTyVarSet
-zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys ->
- returnM (tyVarsOfTypes tys)
+zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar tyvars
zonkTcTyVar :: TcTyVar -> TcM TcType
zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)
- zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
+ zonk_tc_tyvar (\ tv -> return (TyVarTy tv)) tyvar
\end{code}
----------------- Types
\begin{code}
zonkTcType :: TcType -> TcM TcType
-zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) ty
+zonkTcType ty = zonkType (\ tv -> return (TyVarTy tv)) ty
zonkTcTypes :: [TcType] -> TcM [TcType]
-zonkTcTypes tys = mappM zonkTcType tys
-
-zonkTcClassConstraints cts = mappM zonk cts
- where zonk (clas, tys)
- = zonkTcTypes tys `thenM` \ new_tys ->
- returnM (clas, new_tys)
+zonkTcTypes tys = mapM zonkTcType tys
zonkTcThetaType :: TcThetaType -> TcM TcThetaType
-zonkTcThetaType theta = mappM zonkTcPredType theta
+zonkTcThetaType theta = mapM zonkTcPredType theta
zonkTcPredType :: TcPredType -> TcM TcPredType
-zonkTcPredType (ClassP c ts)
- = zonkTcTypes ts `thenM` \ new_ts ->
- returnM (ClassP c new_ts)
-zonkTcPredType (IParam n t)
- = zonkTcType t `thenM` \ new_t ->
- returnM (IParam n new_t)
-zonkTcPredType (EqPred t1 t2)
- = zonkTcType t1 `thenM` \ new_t1 ->
- zonkTcType t2 `thenM` \ new_t2 ->
- returnM (EqPred new_t1 new_t2)
+zonkTcPredType (ClassP c ts) = ClassP c <$> zonkTcTypes ts
+zonkTcPredType (IParam n t) = IParam n <$> zonkTcType t
+zonkTcPredType (EqPred t1 t2) = EqPred <$> zonkTcType t1 <*> zonkTcType t2
\end{code}
------------------- These ...ToType, ...ToKind versions
default_k = defaultKind k
zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
-zonkQuantifiedTyVars = mappM zonkQuantifiedTyVar
+zonkQuantifiedTyVars = mapM zonkQuantifiedTyVar
zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
-- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it.
zonkType unbound_var_fn ty
= go ty
where
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
-
- go (TyConApp tc tys) = mappM go tys `thenM` \ tys' ->
- returnM (TyConApp tc tys')
-
- go (PredTy p) = go_pred p `thenM` \ p' ->
- returnM (PredTy p')
-
- go (FunTy arg res) = go arg `thenM` \ arg' ->
- go res `thenM` \ res' ->
- returnM (FunTy arg' res')
-
- go (AppTy fun arg) = go fun `thenM` \ fun' ->
- go arg `thenM` \ arg' ->
- returnM (mkAppTy fun' arg')
+ go (TyConApp tc tys) = do tys' <- mapM go tys
+ return (TyConApp tc tys')
+
+ go (PredTy p) = do p' <- go_pred p
+ return (PredTy p')
+
+ go (FunTy arg res) = do arg' <- go arg
+ res' <- go res
+ return (FunTy arg' res')
+
+ go (AppTy fun arg) = do fun' <- go fun
+ arg' <- go arg
+ return (mkAppTy fun' arg')
-- NB the mkAppTy; we might have instantiated a
-- type variable to a type constructor, so we need
-- to pull the TyConApp to the top.
| otherwise = return (TyVarTy tyvar)
-- Ordinary (non Tc) tyvars occur inside quantified types
- go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar )
- go ty `thenM` \ ty' ->
- returnM (ForAllTy tyvar ty')
+ go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
+ ty' <- go ty
+ return (ForAllTy tyvar ty')
- go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' ->
- returnM (ClassP c tys')
- go_pred (IParam n ty) = go ty `thenM` \ ty' ->
- returnM (IParam n ty')
- go_pred (EqPred ty1 ty2) = go ty1 `thenM` \ ty1' ->
- go ty2 `thenM` \ ty2' ->
- returnM (EqPred ty1' ty2')
+ go_pred (ClassP c tys) = do tys' <- mapM go tys
+ return (ClassP c tys')
+ go_pred (IParam n ty) = do ty' <- go ty
+ return (IParam n ty')
+ go_pred (EqPred ty1 ty2) = do ty1' <- go ty1
+ ty2' <- go ty2
+ return (EqPred ty1' ty2')
zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
-> TcTyVar -> TcM TcType
zonk_tc_tyvar unbound_var_fn tyvar
| not (isMetaTyVar tyvar) -- Skolems
- = returnM (TyVarTy tyvar)
+ = return (TyVarTy tyvar)
| otherwise -- Mutables
= do { cts <- readMetaTyVar tyvar
\begin{code}
checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that the type is valid for the given context
-checkValidType ctxt ty
- = traceTc (text "checkValidType" <+> ppr ty) `thenM_`
- doptM Opt_UnboxedTuples `thenM` \ unboxed ->
- doptM Opt_Rank2Types `thenM` \ rank2 ->
- doptM Opt_RankNTypes `thenM` \ rankn ->
- doptM Opt_PolymorphicComponents `thenM` \ polycomp ->
+checkValidType ctxt ty = do
+ traceTc (text "checkValidType" <+> ppr ty)
+ unboxed <- doptM Opt_UnboxedTuples
+ rank2 <- doptM Opt_Rank2Types
+ rankn <- doptM Opt_RankNTypes
+ polycomp <- doptM Opt_PolymorphicComponents
let
rank | rankn = Arbitrary
| rank2 = Rank 2
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
ExprSigCtxt | unboxed -> UT_Ok
_ -> UT_NotOk
- in
+
-- Check that the thing has kind Type, and is lifted if necessary
- checkTc kind_ok (kindErr actual_kind) `thenM_`
+ checkTc kind_ok (kindErr actual_kind)
-- Check the internal validity of the type itself
- check_type rank ubx_tup ty `thenM_`
+ check_type rank ubx_tup ty
traceTc (text "checkValidType done" <+> ppr 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 _) = returnM ()
-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 }
-check_type rank ubx_tup (NoteTy other_note ty)
- = check_type rank ubx_tup ty
-
check_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
= do { -- Check that the synonym has enough args
; liberal <- doptM Opt_LiberalTypeSynonyms
; if not liberal || isOpenSynTyCon tc then
-- For H98 and synonym families, do check the type args
- mappM_ check_mono_type tys
+ mapM_ check_mono_type tys
else -- In the liberal case (only for closed syns), expand then check
case tcView ty of
-- c.f. check_arg_type
-- However, args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
- ; mappM_ (check_type rank' UT_Ok) tys }
+ ; mapM_ (check_type rank' UT_Ok) tys }
| otherwise
- = mappM_ (check_arg_type rank) 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
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,
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
----------------------------------------
-forAllTyErr ty = ptext SLIT("Illegal polymorphic or qualified type:") <+> ppr ty
-unliftedArgErr ty = ptext SLIT("Illegal unlifted type:") <+> ppr ty
-ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty
-kindErr kind = 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]
| InstThetaCtxt -- Context of an instance decl
-- instance <S> => 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}
= addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
-------------------------
-check_valid_theta ctxt []
- = returnM ()
-check_valid_theta ctxt theta
- = getDOpts `thenM` \ dflags ->
- warnTc (notNull dups) (dupPredWarn dups) `thenM_`
- mappM_ (check_pred_ty dflags ctxt) theta
+check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM ()
+check_valid_theta _ []
+ = return ()
+check_valid_theta ctxt theta = do
+ dflags <- getDOpts
+ warnTc (notNull dups) (dupPredWarn dups)
+ mapM_ (check_pred_ty dflags ctxt) theta
where
(_,dups) = removeDups tcCmpPred theta
; checkTc (arity == n_tys) arity_err
-- Check the form of the argument types
- ; mappM_ check_mono_type tys
+ ; mapM_ check_mono_type tys
; checkTc (check_class_pred_tys dflags ctxt tys)
(predTyVarErr pred $$ how_to_allow)
}
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)
; 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
-- 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
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
\begin{code}
checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
checkAmbiguity forall_tyvars theta tau_tyvars
- = mappM_ complain (filter is_ambig theta)
+ = mapM_ complain (filter is_ambig theta)
where
complain pred = addErrTc (ambigErr pred)
extended_tau_vars = grow 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
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 $ mappM_ complain (filter is_free theta) }
+ ; unless flexible_contexts $ mapM_ complain (filter is_free theta) }
where
is_free pred = not (isIPPred pred)
&& not (any bound_var (varSetElems (tyVarsOfPred pred)))
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}
case getClassPredTys_maybe pred of {
Nothing -> failWithTc (instTypeErr (pprPred pred) empty) ;
- Just (clas,tys) ->
+ Just (clas,tys) -> do
- getDOpts `thenM` \ dflags ->
- mappM_ check_mono_type tys `thenM_`
- check_inst_head dflags clas tys `thenM_`
- returnM (clas, tys)
+ 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 ||
text "where T is not a synonym." $$
text "Use -XTypeSynonymInstances if you want to disable this.")
- head_type_args_tyvars_msg = parens (
- text "All instance types must be of the form (T a1 ... an)" $$
- text "where a1 ... an are distinct type *variables*" $$
- text "Use -XFlexibleInstances if you want to disable this.")
+ head_type_args_tyvars_msg = parens (vcat [
+ text "All instance types must be of the form (T a1 ... an)",
+ text "where a1 ... an are type *variables*,",
+ text "and each type variable appears at most once in the instance head.",
+ text "Use -XFlexibleInstances if you want to disable this."])
head_one_type_msg = parens (
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}
(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}
| 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}
\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}
%************************************************************************
checkValidTypeInst typats rhs
= do { -- left-hand side contains no type family applications
-- (vanilla synonyms are fine, though)
- ; mappM_ checkTyFamFreeness typats
+ ; mapM_ checkTyFamFreeness typats
-- the right-hand side is a tau type
; checkTc (isTauTy rhs) $
-- 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}
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvType (TyVarTy tv) = [tv]
fvType (TyConApp _ tys) = fvTypes tys
-fvType (NoteTy _ ty) = fvType ty
fvType (PredTy pred) = fvPred pred
fvType (FunTy arg res) = fvType arg ++ fvType res
fvType (AppTy fun arg) = fvType fun ++ fvType arg
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
sizeType (TyVarTy _) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
-sizeType (NoteTy _ ty) = sizeType ty
sizeType (PredTy pred) = sizePred pred
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg
projects / ghc-hetmet.git / blobdiff