Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
4f7599db
Commit
4f7599db
authored
Apr 04, 2012
by
Simon Peyton Jones
Browse files
Tighten up on type validity checking
Fixes Trac
#5957
, which pointed out that Int -> Ord a => a -> a is not Haskell 98
parent
ac2fbb4f
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/ghc.cabal.in
View file @
4f7599db
...
...
@@ -96,7 +96,7 @@ Library
Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards,
ForeignFunctionInterface, EmptyDataDecls,
TypeSynonymInstances, MultiParamTypeClasses,
FlexibleInstances, Rank
2
Types, ScopedTypeVariables,
FlexibleInstances, Rank
N
Types, ScopedTypeVariables,
DeriveDataTypeable, BangPatterns
if impl(ghc >= 7.1)
Extensions: NondecreasingIndentation
...
...
compiler/typecheck/TcMType.lhs
View file @
4f7599db
...
...
@@ -897,32 +897,42 @@ checkValidType :: UserTypeCtxt -> Type -> TcM ()
checkValidType ctxt ty
= do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
; unboxed <- xoptM Opt_UnboxedTuples
; rank2
<- xoptM Opt_Rank2Types
; rankn
<- xoptM Opt_RankNTypes
; rank2
_flag
<- xoptM Opt_Rank2Types
; rankn
_flag
<- xoptM Opt_RankNTypes
; polycomp <- xoptM Opt_PolymorphicComponents
; constraintKinds <- xoptM Opt_ConstraintKinds
; let gen_rank n | rankn = ArbitraryRank
| rank2 = Rank 2
| otherwise = Rank n
rank
; let gen_rank :: Rank -> Rank
gen_rank r | rankn_flag = ArbitraryRank
| rank2_flag = r2
| otherwise = r
rank2 = gen_rank r2
rank1 = gen_rank r1
rank0 = gen_rank r0
r0 = rankZeroMonoType
r1 = LimitedRank True r0
r2 = LimitedRank True r1
rank
= case ctxt of
DefaultDeclCtxt-> MustBeMonoType
ResSigCtxt -> MustBeMonoType
LamPatSigCtxt ->
gen_
rank
0
BindPatSigCtxt ->
gen_
rank
0
TySynCtxt _ ->
gen_
rank
0
LamPatSigCtxt -> rank0
BindPatSigCtxt -> rank0
TySynCtxt _ -> rank0
ExprSigCtxt ->
gen_
rank
1
FunSigCtxt _ ->
gen_
rank
1
ExprSigCtxt -> rank1
FunSigCtxt _ -> rank1
InfSigCtxt _ -> ArbitraryRank -- Inferred type
ConArgCtxt _ | polycomp ->
gen_
rank
2
ConArgCtxt _ | polycomp -> rank2
-- We are given the type of the entire
-- constructor, hence rank 1
| otherwise ->
gen_
rank
1
| otherwise -> rank1
ForSigCtxt _ ->
gen_
rank
1
SpecInstCtxt ->
gen_
rank
1
ThBrackCtxt ->
gen_
rank
1
ForSigCtxt _ -> rank1
SpecInstCtxt -> rank1
ThBrackCtxt -> rank1
GhciCtxt -> ArbitraryRank
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
...
...
@@ -960,23 +970,38 @@ checkValidMonoType :: Type -> TcM ()
checkValidMonoType ty = check_mono_type MustBeMonoType ty
\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
| 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
decRank (Rank 0) = Rank 0
decRank (Rank n) = Rank (n-1)
decRank other_rank = other_rank
| LimitedRank -- Note [Higher rank types]
Bool -- Forall ok at top
Rank -- Use for function arguments
nonZeroRank :: Rank -> Bool
nonZeroRank ArbitraryRank = True
nonZeroRank (Rank n) = n>0
nonZeroRank _ = False
| 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
----------------------------------------
data UbxTupFlag = UT_Ok | UT_NotOk
...
...
@@ -1000,7 +1025,7 @@ check_type :: Rank -> UbxTupFlag -> Type -> TcM ()
check_type rank ubx_tup ty
| not (null tvs && null theta)
= do { checkTc (
nonZeroRank
rank) (forAllTyErr rank ty)
= do { checkTc (
forAllAllowed
rank) (forAllTyErr rank ty)
-- Reject e.g. (Maybe (?x::Int => Int)),
-- with a decent error message
; check_valid_theta SigmaCtxt theta
...
...
@@ -1012,8 +1037,10 @@ check_type rank ubx_tup 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 }
= do { check_type arg_rank UT_NotOk arg_ty
; check_type res_rank UT_Ok res_ty }
where
(arg_rank, res_rank) = funArgResRank rank
check_type rank _ (AppTy ty1 ty2)
= do { check_arg_type rank ty1
...
...
@@ -1033,7 +1060,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
; liberal <- xoptM Opt_LiberalTypeSynonyms
; if not liberal || isSynFamilyTyCon tc then
-- For H98 and synonym families, do check the type args
mapM_ (check_mono_type
S
ynArgMonoType) tys
mapM_ (check_mono_type
s
ynArgMonoType) tys
else -- In the liberal case (only for closed syns), expand then check
case tcView ty of
...
...
@@ -1046,7 +1073,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg
; impred <- xoptM Opt_ImpredicativeTypes
; let rank' = if impred then ArbitraryRank else
T
yConArgMonoType
; let rank' = if impred then ArbitraryRank else
t
yConArgMonoType
-- c.f. check_arg_type
-- However, args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
...
...
@@ -1097,7 +1124,7 @@ check_arg_type rank ty
; let rank' = case rank of -- Predictive => must be monotype
MustBeMonoType -> MustBeMonoType -- Monotype, regardless
_other | impred -> ArbitraryRank
| otherwise ->
T
yConArgMonoType
| otherwise ->
t
yConArgMonoType
-- Make sure that MustBeMonoType is propagated,
-- so that we don't suggest -XImpredicativeTypes in
-- (Ord (forall a.a)) => a -> a
...
...
@@ -1117,10 +1144,9 @@ forAllTyErr rank 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
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]
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment