[commit: ghc] master: Be more aggressive when checking constraints for custom type errors. (b75d194)
git at git.haskell.org
git at git.haskell.org
Wed May 4 13:02:03 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/b75d1940dd3362382c0bc94018a9045c2def82a9/ghc
>---------------------------------------------------------------
commit b75d1940dd3362382c0bc94018a9045c2def82a9
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date: Tue May 3 22:55:07 2016 +0200
Be more aggressive when checking constraints for custom type errors.
This fixes #11990.
The current rule is simpler than before: if we encounter an unsolved
constraint that contains any mentions of properly applied `TypeError`,
then we report the type error.
If there are multiple `TypeErrors`, then we just report one of them.
Reviewers: simonpj, bgamari, austin
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2151
GHC Trac Issues: #11990
>---------------------------------------------------------------
b75d1940dd3362382c0bc94018a9045c2def82a9
compiler/typecheck/TcRnTypes.hs | 55 ++++++++++++++++++----
testsuite/tests/typecheck/should_fail/T11990a.hs | 24 ++++++++++
.../tests/typecheck/should_fail/T11990a.stderr | 5 ++
testsuite/tests/typecheck/should_fail/T11990b.hs | 28 +++++++++++
.../tests/typecheck/should_fail/T11990b.stderr | 5 ++
testsuite/tests/typecheck/should_fail/all.T | 2 +
6 files changed, 109 insertions(+), 10 deletions(-)
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index bce7002..dc05c13 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1782,18 +1782,53 @@ isTypeHoleCt :: Ct -> Bool
isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True
isTypeHoleCt _ = False
--- | The following constraints are considered to be a custom type error:
--- 1. TypeError msg a b c
--- 2. TypeError msg a b c ~ Something (and the other way around)
--- 4. C (TypeError msg a b c) (for any parameter of class constraint)
+
+{- Note [Custom type errors in constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When GHC reports a type-error about an unsolved-constraint, we check
+to see if the constraint contains any custom-type errors, and if so
+we report them. Here are some examples of constraints containing type
+errors:
+
+TypeError msg -- The actual constraint is a type error
+
+TypError msg ~ Int -- Some type was supposed to be Int, but ended up
+ -- being a type error instead
+
+Eq (TypeError msg) -- A class constraint is stuck due to a type error
+
+F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err
+
+It is also possible to have constraints where the type error is nested deeper,
+for example see #11990, and also:
+
+Eq (F (TypeError msg)) -- Here the type error is nested under a type-function
+ -- call, which failed to evaluate because of it,
+ -- and so the `Eq` constraint was unsolved.
+ -- This may happen when one function calls another
+ -- and the called function produced a custom type error.
+-}
+
+-- | A constraint is considered to be a custom type error, if it contains
+-- custom type errors anywhere in it.
+-- See Note [Custom type errors in constraints]
getUserTypeErrorMsg :: Ct -> Maybe Type
-getUserTypeErrorMsg ct
- | Just (_,t1,t2) <- getEqPredTys_maybe ctT = oneOf [t1,t2]
- | Just (_,ts) <- getClassPredTys_maybe ctT = oneOf ts
- | otherwise = userTypeError_maybe ctT
+getUserTypeErrorMsg ct = findUserTypeError (ctPred ct)
where
- ctT = ctPred ct
- oneOf xs = msum (map userTypeError_maybe xs)
+ findUserTypeError t = msum ( userTypeError_maybe t
+ : map findUserTypeError (subTys t)
+ )
+
+ subTys t = case splitAppTys t of
+ (t,[]) ->
+ case splitTyConApp_maybe t of
+ Nothing -> []
+ Just (_,ts) -> ts
+ (t,ts) -> t : ts
+
+
+
isUserTypeErrorCt :: Ct -> Bool
isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
diff --git a/testsuite/tests/typecheck/should_fail/T11990a.hs b/testsuite/tests/typecheck/should_fail/T11990a.hs
new file mode 100644
index 0000000..7b7a03b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11990a.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-}
+
+module T11990a where
+
+import GHC.TypeLits
+import Data.Proxy
+
+type family PartialTF t :: Symbol where
+ PartialTF Int = "Int"
+ PartialTF Bool = "Bool"
+ PartialTF a = TypeError (Text "Unexpected type @ PartialTF: "
+ :<>: ShowType a)
+
+testPartialTF :: forall a.(KnownSymbol (PartialTF a)) => a -> String
+testPartialTF t = symbolVal (Proxy :: Proxy (PartialTF a))
+
+t1 = testPartialTF 'a'
+
+{- Above code rightly fails with the following error:
+ • Unexpected type: Char
+ • In the expression: testPartialTF 'a'
+ In an equation for ‘t1’: t1 = testPartialTF 'a'
+-}
diff --git a/testsuite/tests/typecheck/should_fail/T11990a.stderr b/testsuite/tests/typecheck/should_fail/T11990a.stderr
new file mode 100644
index 0000000..f875e67
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11990a.stderr
@@ -0,0 +1,5 @@
+
+T11990a.hs:18:6:
+ Unexpected type @ PartialTF: Char
+ In the expression: testPartialTF 'a'
+ In an equation for ‘t1’: t1 = testPartialTF 'a'
diff --git a/testsuite/tests/typecheck/should_fail/T11990b.hs b/testsuite/tests/typecheck/should_fail/T11990b.hs
new file mode 100644
index 0000000..9a31670
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11990b.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-}
+
+module T11990b where
+
+import GHC.TypeLits
+import Data.Proxy
+
+type family PartialTF t :: Symbol where
+ PartialTF Int = "Int"
+ PartialTF Bool = "Bool"
+ PartialTF a = TypeError (Text "Unexpected type @ PartialTF: "
+ :<>: ShowType a)
+
+type family NestedPartialTF (tsym :: Symbol) :: Symbol where
+ NestedPartialTF "Int" = "int"
+ NestedPartialTF "Bool" = "bool"
+ NestedPartialTF a =
+ TypeError (Text "Unexpected type @ NestedPartialTF: " :<>: ShowType a)
+
+testPartialTF :: forall a.(KnownSymbol (PartialTF a)) => a -> String
+testPartialTF t = symbolVal (Proxy :: Proxy (PartialTF a))
+
+testNesPartialTF ::
+ forall a.(KnownSymbol (NestedPartialTF (PartialTF a))) => a -> String
+testNesPartialTF t = symbolVal (Proxy :: Proxy (NestedPartialTF (PartialTF a)))
+
+t2 = testNesPartialTF 'a'
diff --git a/testsuite/tests/typecheck/should_fail/T11990b.stderr b/testsuite/tests/typecheck/should_fail/T11990b.stderr
new file mode 100644
index 0000000..9a92d43
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11990b.stderr
@@ -0,0 +1,5 @@
+
+T11990b.hs:28:6:
+ Unexpected type @ PartialTF: Char
+ In the expression: testNesPartialTF 'a'
+ In an equation for ‘t2’: t2 = testNesPartialTF 'a'
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 3310ec9..6519768 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -416,3 +416,5 @@ test('BadUnboxedTuple', normal, compile_fail, [''])
test('T11698', normal, compile_fail, [''])
test('T11947a', normal, compile_fail, [''])
test('T11948', normal, compile_fail, [''])
+test('T11990a', normal, compile_fail, [''])
+test('T11990b', normal, compile_fail, [''])
More information about the ghc-commits
mailing list