Commit f879703d authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Add missing file TcValidity.lhs

This should have been part of
  commit 97db0edc
  Re-engineer the ambiguity test for user type signatures
parent 7dffc188
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module TcValidity (
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
expectedKindInCtxt,
checkValidTheta, checkValidFamPats,
checkValidInstHead, checkValidInstance, validDerivPred,
checkInstTermination, checkValidTyFamInst, checkTyFamFreeness,
arityErr
) where
#include "HsVersions.h"
-- friends:
import TcUnify ( tcSubType )
import TcSimplify ( simplifyTop )
import TypeRep
import TcType
import TcMType
import Type
import Kind
import Class
import TyCon
-- others:
import HsSyn -- HsType
import TcRnMonad -- TcType, amongst others
import FunDeps
import Name
import VarSet
import ErrUtils
import PrelNames
import DynFlags
import Util
import Maybes
import ListSetOps
import SrcLoc
import Outputable
import FastString
import Control.Monad
import Data.List ( (\\) )
\end{code}
%************************************************************************
%* *
Checking for ambiguity
%* *
%************************************************************************
\begin{code}
checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity ctxt ty
= do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes
; unless allow_ambiguous $
do {(subst, _tvs) <- tcInstSkolTyVars (varSetElems (tyVarsOfType ty))
; let ty' = substTy subst ty
-- The type might have free TyVars,
-- so we skolemise them as TcTyVars
-- Tiresome; but the type inference engine expects TcTyVars
; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $
captureConstraints $
tcSubType (AmbigOrigin ctxt) ctxt ty' ty'
-- Solve the constraints eagerly because an ambiguous type
-- can cause a cascade of further errors. The free tyvars
-- are skolemised, so we can safely use tcSimplifyTop
; _ev_binds <- simplifyTop wanted
; return () } }
where
mk_msg ty tidy_env
= return (tidy_env', msg)
where
(tidy_env', tidy_ty) = tidyOpenType tidy_env ty
msg = hang (ptext (sLit "In the ambiguity check for:"))
2 (ppr tidy_ty)
\end{code}
%************************************************************************
%* *
Checking validity of a user-defined type
%* *
%************************************************************************
When dealing with a user-written type, we first translate it from an HsType
to a Type, performing kind checking, and then check various things that should
be true about it. We don't want to perform these checks at the same time
as the initial translation because (a) they are unnecessary for interface-file
types and (b) when checking a mutually recursive group of type and class decls,
we can't "look" at the tycons/classes yet. Also, the checks are are rather
diverse, and used to really mess up the other code.
One thing we check for is 'rank'.
Rank 0: monotypes (no foralls)
Rank 1: foralls at the front only, Rank 0 inside
Rank 2: foralls at the front, Rank 1 on left of fn arrow,
basic ::= tyvar | T basic ... basic
r2 ::= forall tvs. cxt => r2a
r2a ::= r1 -> r2a | basic
r1 ::= forall tvs. cxt => r0
r0 ::= r0 -> r0 | basic
Another thing is to check that type synonyms are saturated.
This might not necessarily show up in kind checking.
type A i = i
data T k = MkT (k Int)
f :: T A -- BAD!
\begin{code}
checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that the type is valid for the given context
-- Not used for instance decls; checkValidInstance instead
checkValidType ctxt ty
= do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
; rankn_flag <- xoptM Opt_RankNTypes
; let gen_rank :: Rank -> Rank
gen_rank r | rankn_flag = ArbitraryRank
| otherwise = r
rank1 = gen_rank r1
rank0 = gen_rank r0
r0 = rankZeroMonoType
r1 = LimitedRank True r0
rank
= case ctxt of
DefaultDeclCtxt-> MustBeMonoType
ResSigCtxt -> MustBeMonoType
LamPatSigCtxt -> rank0
BindPatSigCtxt -> rank0
RuleSigCtxt _ -> rank1
TySynCtxt _ -> rank0
ExprSigCtxt -> rank1
FunSigCtxt _ -> rank1
InfSigCtxt _ -> ArbitraryRank -- Inferred type
ConArgCtxt _ -> rank1 -- We are given the type of the entire
-- constructor, hence rank 1
ForSigCtxt _ -> rank1
SpecInstCtxt -> rank1
ThBrackCtxt -> rank1
GhciCtxt -> ArbitraryRank
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
-- Check the internal validity of the type itself
; check_type ctxt rank ty
-- Check that the thing has kind Type, and is lifted if necessary
-- Do this second, because we can't usefully take the kind of an
-- ill-formed type such as (a~Int)
; check_kind ctxt ty }
checkValidMonoType :: Type -> TcM ()
checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty
check_kind :: UserTypeCtxt -> TcType -> TcM ()
-- Check that the type's kind is acceptable for the context
check_kind ctxt ty
| TySynCtxt {} <- ctxt
= do { ck <- xoptM Opt_ConstraintKinds
; unless ck $
checkTc (not (returnsConstraintKind actual_kind))
(constraintSynErr actual_kind) }
| Just k <- expectedKindInCtxt ctxt
= checkTc (tcIsSubKind actual_kind k) (kindErr actual_kind)
| otherwise
= return () -- Any kind will do
where
actual_kind = typeKind ty
-- Depending on the context, we might accept any kind (for instance, in a TH
-- splice), or only certain kinds (like in type signatures).
expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind
expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do
expectedKindInCtxt ThBrackCtxt = Nothing
expectedKindInCtxt GhciCtxt = Nothing
expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind
expectedKindInCtxt InstDeclCtxt = Just constraintKind
expectedKindInCtxt SpecInstCtxt = Just constraintKind
expectedKindInCtxt _ = Just openTypeKind
\end{code}
Note [Higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~
Technically
Int -> forall a. a->a
is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the
validity checker allow a forall after an arrow only if we allow it
before -- that is, with Rank2Types or RankNTypes
\begin{code}
data Rank = ArbitraryRank -- Any rank ok
| LimitedRank -- Note [Higher rank types]
Bool -- Forall ok at top
Rank -- Use for function arguments
| MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype
| MustBeMonoType -- Monotype regardless of flags
rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank
rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types"))
tyConArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XImpredicativeTypes"))
synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms"))
funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result
funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
funArgResRank other_rank = (other_rank, other_rank)
forAllAllowed :: Rank -> Bool
forAllAllowed ArbitraryRank = True
forAllAllowed (LimitedRank forall_ok _) = forall_ok
forAllAllowed _ = False
----------------------------------------
check_mono_type :: UserTypeCtxt -> Rank
-> KindOrType -> TcM () -- No foralls anywhere
-- No unlifted types of any kind
check_mono_type ctxt rank ty
| isKind ty = return () -- IA0_NOTE: Do we need to check kinds?
| otherwise
= do { check_type ctxt rank ty
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
check_type :: UserTypeCtxt -> Rank -> Type -> TcM ()
-- 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
-- Rank 0 means no for-alls anywhere
check_type ctxt rank ty
| not (null tvs && null theta)
= do { checkTc (forAllAllowed rank) (forAllTyErr rank ty)
-- Reject e.g. (Maybe (?x::Int => Int)),
-- with a decent error message
; check_valid_theta ctxt theta
; check_type ctxt rank tau -- Allow foralls to right of arrow
; checkAmbiguity ctxt ty }
where
(tvs, theta, tau) = tcSplitSigmaTy ty
check_type _ _ (TyVarTy _) = return ()
check_type ctxt rank (FunTy arg_ty res_ty)
= do { check_type ctxt arg_rank arg_ty
; check_type ctxt res_rank res_ty }
where
(arg_rank, res_rank) = funArgResRank rank
check_type ctxt rank (AppTy ty1 ty2)
= do { check_arg_type ctxt rank ty1
; check_arg_type ctxt rank ty2 }
check_type ctxt rank ty@(TyConApp tc tys)
| isSynTyCon tc
= do { -- Check that the synonym has enough args
-- This applies equally to open and closed synonyms
-- It's OK to have an *over-applied* type synonym
-- data Tree a b = ...
-- type Foo a = Tree [a]
-- f :: Foo a b -> ...
checkTc (tyConArity tc <= length tys) arity_msg
-- See Note [Liberal type synonyms]
; liberal <- xoptM Opt_LiberalTypeSynonyms
; if not liberal || isSynFamilyTyCon tc then
-- For H98 and synonym families, do check the type args
mapM_ (check_mono_type ctxt synArgMonoType) tys
else -- In the liberal case (only for closed syns), expand then check
case tcView ty of
Just ty' -> check_type ctxt rank ty'
Nothing -> pprPanic "check_tau_type" (ppr ty)
}
| isUnboxedTupleTyCon tc
= do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples
; checkTc ub_tuples_allowed ubx_tup_msg
; impred <- xoptM Opt_ImpredicativeTypes
; 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_type ctxt rank') tys }
| otherwise
= mapM_ (check_arg_type ctxt rank) tys
where
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 _ _ (LitTy {}) = return ()
check_type _ _ ty = pprPanic "check_type" (ppr ty)
----------------------------------------
check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM ()
-- The sort of type that can instantiate a type variable,
-- or be the argument of a type constructor.
-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
-- Other unboxed types are very occasionally allowed as type
-- arguments depending on the kind of the type constructor
--
-- For example, we want to reject things like:
--
-- instance Ord a => Ord (forall s. T s a)
-- and
-- g :: T s (forall b.b)
--
-- NB: unboxed tuples can have polymorphic or unboxed args.
-- This happens in the workers for functions returning
-- product types with polymorphic components.
-- But not in user code.
-- Anyway, they are dealt with by a special case in check_tau_type
check_arg_type ctxt rank ty
| isKind ty = return () -- IA0_NOTE: Do we need to check a kind?
| otherwise
= do { impred <- xoptM Opt_ImpredicativeTypes
; 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 ctxt rank' ty
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
-- NB the isUnLiftedType test also checks for
-- T State#
-- where there is an illegal partial application of State# (which has
-- kind * -> #); see Note [The kind invariant] in TypeRep
----------------------------------------
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
LimitedRank {} -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")
MonoType d -> d
_ -> 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
doing validity checking. This allows us to instantiate a synonym defn
with a for-all type, or with a partially-applied type synonym.
e.g. type T a b = a
type S m = m ()
f :: S (T Int)
Here, T is partially applied, so it's illegal in H98. But if you
expand S first, then T we get just
f :: Int
which is fine.
IMPORTANT: suppose T is a type synonym. Then we must do validity
checking on an appliation (T ty1 ty2)
*either* before expansion (i.e. check ty1, ty2)
*or* after expansion (i.e. expand T ty1 ty2, and then check)
BUT NOT BOTH
If we do both, we get exponential behaviour!!
data TIACons1 i r c = c i ::: r c
type TIACons2 t x = TIACons1 t (TIACons1 t x)
type TIACons3 t x = TIACons2 t (TIACons1 t x)
type TIACons4 t x = TIACons2 t (TIACons2 t x)
type TIACons7 t x = TIACons4 t (TIACons3 t x)
%************************************************************************
%* *
\subsection{Checking a theta or source type}
%* *
%************************************************************************
\begin{code}
checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
checkValidTheta ctxt theta
= addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
-------------------------
check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM ()
check_valid_theta _ []
= return ()
check_valid_theta ctxt theta
= do { dflags <- getDynFlags
; warnTc (wopt Opt_WarnDuplicateConstraints dflags &&
notNull dups) (dupPredWarn dups)
; mapM_ (check_pred_ty dflags ctxt) theta }
where
(_,dups) = removeDups cmpPred theta
-------------------------
check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM ()
-- Check the validity of a predicate in a signature
-- We look through any type synonyms; any constraint kinded
-- type synonyms have been checked at their definition site
check_pred_ty dflags ctxt pred
| Just (tc,tys) <- tcSplitTyConApp_maybe pred
= case () of
_ | Just cls <- tyConClass_maybe tc
-> check_class_pred dflags ctxt cls tys
| tc `hasKey` eqTyConKey
, let [_, ty1, ty2] = tys
-> check_eq_pred dflags ctxt ty1 ty2
| isTupleTyCon tc
-> check_tuple_pred dflags ctxt pred tys
| otherwise -- X t1 t2, where X is presumably a
-- type/data family returning ConstraintKind
-> check_irred_pred dflags ctxt pred tys
| (TyVarTy _, arg_tys) <- tcSplitAppTys pred
= check_irred_pred dflags ctxt pred arg_tys
| otherwise
= badPred pred
badPred :: PredType -> TcM ()
badPred pred = failWithTc (ptext (sLit "Malformed predicate") <+> quotes (ppr pred))
check_class_pred :: DynFlags -> UserTypeCtxt -> Class -> [TcType] -> TcM ()
check_class_pred dflags ctxt cls tys
= do { -- Class predicates are valid in all contexts
; checkTc (arity == n_tys) arity_err
-- Check the form of the argument types
; mapM_ checkValidMonoType tys
; checkTc (check_class_pred_tys dflags ctxt tys)
(predTyVarErr (mkClassPred cls tys) $$ how_to_allow)
}
where
class_name = className cls
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"))
check_eq_pred :: DynFlags -> UserTypeCtxt -> TcType -> TcType -> TcM ()
check_eq_pred dflags _ctxt ty1 ty2
= do { -- Equational constraints are valid in all contexts if type
-- families are permitted
; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags)
(eqPredTyErr (mkEqPred ty1 ty2))
-- Check the form of the argument types
; checkValidMonoType ty1
; checkValidMonoType ty2
}
check_tuple_pred :: DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
check_tuple_pred dflags ctxt pred ts
= do { checkTc (xopt Opt_ConstraintKinds dflags)
(predTupleErr pred)
; mapM_ (check_pred_ty dflags ctxt) ts }
-- This case will not normally be executed because
-- without -XConstraintKinds tuple types are only kind-checked as *
check_irred_pred :: DynFlags -> UserTypeCtxt -> PredType -> [TcType] -> TcM ()
check_irred_pred dflags ctxt pred arg_tys
-- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
-- But X is not a synonym; that's been expanded already
--
-- Allowing irreducible predicates in class superclasses is somewhat dangerous
-- because we can write:
--
-- type family Fooish x :: * -> Constraint
-- type instance Fooish () = Foo
-- class Fooish () a => Foo a where
--
-- This will cause the constraint simplifier to loop because every time we canonicalise a
-- (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
-- solved to add+canonicalise another (Foo a) constraint.
--
-- It is equally dangerous to allow them in instance heads because in that case the
-- Paterson conditions may not detect duplication of a type variable or size change.
= do { checkTc (xopt Opt_ConstraintKinds dflags)
(predIrredErr pred)
; mapM_ checkValidMonoType arg_tys
; unless (xopt Opt_UndecidableInstances dflags) $
-- Make sure it is OK to have an irred pred in this context
checkTc (case ctxt of ClassSCCtxt _ -> False; InstDeclCtxt -> False; _ -> True)
(predIrredBadCtxtErr pred) }
-------------------------
check_class_pred_tys :: DynFlags -> UserTypeCtxt -> [KindOrType] -> Bool
check_class_pred_tys dflags ctxt kts
= case ctxt of
SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
InstDeclCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
-- Further checks on head and theta in
-- checkInstTermination
_ -> flexible_contexts || all tyvar_head tys
where
(_, tys) = span isKind kts -- see Note [Kind polymorphic type classes]
flexible_contexts = xopt Opt_FlexibleContexts dflags
undecidable_ok = xopt 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
= case tcSplitAppTy_maybe ty of
Just (ty, _) -> tyvar_head ty
Nothing -> False
\end{code}
Note [Kind polymorphic type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MultiParam check:
class C f where... -- C :: forall k. k -> Constraint
instance C Maybe where...
The dictionary gets type [C * Maybe] even if it's not a MultiParam
type class.
Flexibility check:
class C f where... -- C :: forall k. k -> Constraint
data D a = D a
instance C D where
The dictionary gets type [C * (D *)]. IA0_TODO it should be
generalized actually.
Note [The ambiguity check for type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
checkAmbiguity is a check on user-supplied type signatures. It is
*purely* there to report functions that cannot possibly be called. So for
example we want to reject:
f :: C a => Int
The idea is there can be no legal calls to 'f' because every call will
give rise to an ambiguous constraint. We could soundly omit the
ambiguity check on type signatures entirely, at the expense of
delaying ambiguity errors to call sites. Indeed, the flag
-XAllowAmbiguousTypes switches off the ambiguity check.
What about things like this:
class D a b | a -> b where ..
h :: D Int b => Int
The Int may well fix 'b' at the call site, so that signature should
not be rejected. Moreover, using *visible* fundeps is too
conservative. Consider
class X a b where ...
class D a b | a -> b where ...
instance D a b => X [a] b where...
h :: X a b => a -> a
Here h's type looks ambiguous in 'b', but here's a legal call:
...(h [True])...
That gives rise to a (X [Bool] beta) constraint, and using the
instance means we need (D Bool beta) and that fixes 'beta' via D's
fundep!
Behind all these special cases there is a simple guiding principle.
Consider
f :: <type>
f = ...blah...
g :: <type>
g = f
You would think that the definition of g would surely typecheck!
After all f has exactly the same type, and g=f. But in fact f's type
is instantiated and the instantiated constraints are solved against
the originals, so in the case an ambiguous type it won't work.
Consider our earlier example f :: C a => Int. Then in g's definition,
we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
and fail.
So in fact we use this as our *definition* of ambiguity. We use a
very similar test for *inferred* types, to ensure that they are
unambiguous. See Note [Impedence matching] in TcBinds.
This test is very conveniently implemented by calling
tcSubType <type> <type>
This neatly takes account of the functional dependecy stuff above,
and implict parameter (see Note [Implicit parameters and ambiguity]).
What about this, though?
g :: C [a] => Int
Is every call to 'g' ambiguous? After all, we might have
intance C [a] where ...
at the call site. So maybe that type is ok! Indeed even f's
quintessentially ambiguous type might, just possibly be callable:
with -XFlexibleInstances we could have
instance C a where ...
and now a call could be legal after all! Well, we'll reject this
unless the instance is available *here*.
Side note: the ambiguity check is only used for *user* types, not for
types coming from inteface files. The latter can legitimately have
ambiguous types. Example
class S a where s :: a -> (Int,Int)
instance S Char where s _ = (1,1)
f:: S a => [a] -> Int -> (Int,Int)
f (_::[a]) x = (a*x,b)