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,
--------------------------------
-- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
- tcInstSigTyVars,
- tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
- tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
+ 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
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
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
-- (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
--
| isSynTyCon tc = go_syn tc 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
+ go (PredTy p) = do { p' <- go_pred p
; return $ occurs1 PredTy p' }
go (FunTy arg res) = do { arg' <- go arg
; res' <- go res
-- 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
--------------
+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)
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_kv"))
(mkCoKind ty1 ty2)
| ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
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) }
-- 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}
; 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) $
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
-#endif
\end{code}
%************************************************************************
\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
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
--
-- 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
* 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 = ()
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]
~~~~~~~~~~~~~~~~~~~~~~~~
zonkType unbound_var_fn ty
= go ty
where
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
-
go (TyConApp tc tys) = do tys' <- mapM go tys
return (TyConApp tc tys')
-- 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}
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
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
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 }
-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
- 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
; 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
= 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,
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 = 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 :: 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]
| 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 []
+check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM ()
+check_valid_theta _ []
= return ()
check_valid_theta ctxt theta = do
dflags <- getDOpts
; 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)
}
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
-- 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
= 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 &&
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
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) }
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}
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 (
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}
%* *
%************************************************************************
-
\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)
-- 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
| 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}
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.
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
\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}
%************************************************************************
\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
; 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
checkTyFamFreeness :: Type -> TcM ()
checkTyFamFreeness ty
= checkTc (isTyFamFree ty) $
- tyFamInstInIndexErr ty
+ tyFamInstIllegalErr ty
-- Check that a type does not contain any type family applications.
--
-- 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}
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
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}