[commit: ghc] master: Fix #13311 by using tcSplitNestedSigmaTys in the right place (c3a7862)
git at git.haskell.org
git at git.haskell.org
Mon Jul 3 22:58:58 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/c3a78623cf7bb74c8ca0749f1216e802aa37a721/ghc
>---------------------------------------------------------------
commit c3a78623cf7bb74c8ca0749f1216e802aa37a721
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Mon Jul 3 16:54:14 2017 -0400
Fix #13311 by using tcSplitNestedSigmaTys in the right place
Previously, we we only using `tcSplitSigmaTy` when determining if a
function had been applied to too few arguments, so it wouldn't work for
functions with nested `forall`s. Thankfully, this is easily fixed with a
dash of `tcSplitNestedSigmaTys`.
Test Plan: make test TEST=T13311
Reviewers: austin, bgamari, simonpj
Reviewed By: bgamari
Subscribers: goldfire, simonpj, rwbarton, thomie
GHC Trac Issues: #13311
Differential Revision: https://phabricator.haskell.org/D3678
>---------------------------------------------------------------
c3a78623cf7bb74c8ca0749f1216e802aa37a721
compiler/typecheck/TcExpr.hs | 44 +++++++++++++++++++++-
compiler/typecheck/TcTyClsDecls.hs | 11 +++---
testsuite/tests/typecheck/should_fail/T13311.hs | 10 +++++
.../tests/typecheck/should_fail/T13311.stderr | 12 ++++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
5 files changed, 72 insertions(+), 6 deletions(-)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 960d181..cf8bf0c 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -2413,7 +2413,11 @@ addFunResCtxt has_args fun fun_res_ty env_ty
do { dumping <- doptM Opt_D_dump_tc_trace
; MASSERT( dumping )
; newFlexiTyVarTy liftedTypeKind }
- ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'
+ ; let -- See Note [Splitting nested sigma types in mismatched
+ -- function types]
+ (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
+ -- No need to call tcSplitNestedSigmaTys here, since env_ty is
+ -- an ExpRhoTy, i.e., it's already deeply instantiated.
(_, _, env_tau) = tcSplitSigmaTy env'
(args_fun, res_fun) = tcSplitFunTys fun_tau
(args_env, res_env) = tcSplitFunTys env_tau
@@ -2440,6 +2444,44 @@ addFunResCtxt has_args fun fun_res_ty env_ty
Just (tc, _) -> isAlgTyCon tc
Nothing -> False
+{-
+Note [Splitting nested sigma types in mismatched function types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When one applies a function to too few arguments, GHC tries to determine this
+fact if possible so that it may give a helpful error message. It accomplishes
+this by checking if the type of the applied function has more argument types
+than supplied arguments.
+
+Previously, GHC computed the number of argument types through tcSplitSigmaTy.
+This is incorrect in the face of nested foralls, however! This caused Trac
+#13311, for instance:
+
+ f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
+
+If one uses `f` like so:
+
+ do { f; putChar 'a' }
+
+Then tcSplitSigmaTy will decompose the type of `f` into:
+
+ Tyvars: [a]
+ Context: (Monoid a)
+ Argument types: []
+ Return type: forall b. Monoid b => Maybe a -> Maybe b
+
+That is, it will conclude that there are *no* argument types, and since `f`
+was given no arguments, it won't print a helpful error message. On the other
+hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:
+
+ Tyvars: [a, b]
+ Context: (Monoid a, Monoid b)
+ Argument types: [Maybe a]
+ Return type: Maybe b
+
+So now GHC recognizes that `f` has one more argument type than it was actually
+provided.
+-}
+
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes prs
= hang (text "Record update for insufficiently polymorphic field"
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index d253dc3..7400483 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2498,7 +2498,7 @@ checkValidClass cls
op_name = idName sel_id
op_ty = idType sel_id
(_,cls_pred,tau1) = tcSplitMethodTy op_ty
- -- See Note [Splitting nested sigma types]
+ -- See Note [Splitting nested sigma types in class type signatures]
(_,op_theta,tau2) = tcSplitNestedSigmaTys tau1
check_constraint :: TcPredType -> TcM ()
@@ -2550,7 +2550,8 @@ checkValidClass cls
-- Note [Default method type signatures must align]
-- to learn why this is OK.
--
- -- See also Note [Splitting nested sigma types]
+ -- See also
+ -- Note [Splitting nested sigma types in class type signatures]
-- for an explanation of why we don't use tcSplitSigmaTy here.
(_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty
@@ -2715,10 +2716,10 @@ when we validity-check default type signatures, we ignore contexts completely.
Note that when checking whether two type signatures match, we must take care to
split as many foralls as it takes to retrieve the tau types we which to check.
-See Note [Splitting nested sigma types].
+See Note [Splitting nested sigma types in class type signatures].
-Note [Splitting nested sigma types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Splitting nested sigma types in class type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this type synonym and class definition:
type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
diff --git a/testsuite/tests/typecheck/should_fail/T13311.hs b/testsuite/tests/typecheck/should_fail/T13311.hs
new file mode 100644
index 0000000..811d6fe
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13311.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+module T13311 where
+
+f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
+f _ = mempty
+
+g :: IO ()
+g = do
+ f
+ putChar 'a'
diff --git a/testsuite/tests/typecheck/should_fail/T13311.stderr b/testsuite/tests/typecheck/should_fail/T13311.stderr
new file mode 100644
index 0000000..923f378
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13311.stderr
@@ -0,0 +1,12 @@
+
+T13311.hs:9:3: error:
+ • Couldn't match expected type ‘IO a1’
+ with actual type ‘Maybe a0 -> Maybe b0’
+ • Probable cause: ‘f’ is applied to too few arguments
+ In a stmt of a 'do' block: f
+ In the expression:
+ do f
+ putChar 'a'
+ In an equation for ‘g’:
+ g = do f
+ putChar 'a'
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 5cc8171..2ac572f 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -435,6 +435,7 @@ test('LevPolyBounded', normal, compile_fail, [''])
test('T13487', normal, compile, [''])
test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])
test('T13300', normal, compile_fail, [''])
+test('T13311', normal, compile_fail, [''])
test('T12709', normal, compile_fail, [''])
test('T13446', normal, compile_fail, [''])
test('T13506', normal, compile_fail, [''])
More information about the ghc-commits
mailing list