[commit: ghc] master: Keep kind-inconsistent Given type equalities (fixes Trac #8705) (89d2c04)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/89d2c048c81020a701ac94d949b4d6f1ced37cfa/ghc

>---------------------------------------------------------------

commit 89d2c048c81020a701ac94d949b4d6f1ced37cfa
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Feb 18 11:07:36 2014 +0000

    Keep kind-inconsistent Given type equalities (fixes Trac #8705)
    
    I was too eager when fixing Trac #8566, and dropped too many
    equalities on the floor, thereby causing Trac #8705.
    
    The fix is easy: delete code.  Lots of new comments!


>---------------------------------------------------------------

89d2c048c81020a701ac94d949b4d6f1ced37cfa
 compiler/typecheck/TcSMonad.lhs    |   34 ++++++++++++++++++++--------------
 testsuite/tests/polykinds/T8705.hs |   23 +++++++++++++++++++++++
 testsuite/tests/polykinds/all.T    |    1 +
 3 files changed, 44 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 2785215..a92bc95 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1638,14 +1638,10 @@ See Note [Coercion evidence terms] in TcEvidence.
 
 Note [Do not create Given kind equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want to create a Given like
+We do not want to create a Given kind equality like
 
-     kv ~ k            -- kv is a skolem kind variable
-                       -- Reason we don't yet support non-Refl kind equalities
-
-or   t1::k1 ~ t2::k2   -- k1 and k2 are un-equal kinds
-                       -- Reason: (~) is kind-uniform at the moment, and
-                       -- k1/k2 may be distinct kind skolems
+   [G]  kv ~ k   -- kv is a skolem kind variable
+                 -- Reason we don't yet support non-Refl kind equalities
 
 This showed up in Trac #8566, where we had a data type
    data I (u :: U *) (r :: [*]) :: * where
@@ -1656,14 +1652,24 @@ so A has type
         (u ~ AA * k t as) => I u r
 
 There is no direct kind equality, but in a pattern match where 'u' is
-instantiated to, say, (AA * kk t1 as1), we'd decompose to get
+instantiated to, say, (AA * kk (t1:kk) as1), we'd decompose to get
    k ~ kk, t ~ t1, as ~ as1
-This is bad.  We "fix" this by simply ignoring
-  *     the Given kind equality
-  * AND the Given type equality (t:k1) ~ (t1:kk)
-
+This is bad.  We "fix" this by simply ignoring the Given kind equality
 But the Right Thing is to add kind equalities!
 
+But note (Trac #8705) that we *do* create Given (non-canonical) equalities
+with un-equal kinds, e.g.
+   [G]  t1::k1 ~ t2::k2   -- k1 and k2 are un-equal kinds
+Reason: k1 or k2 might be unification variables that have already been
+unified (at this point we have not canonicalised the types), so we want
+to emit this t1~t2 as a (non-canonical) Given in the work-list. If k1/k2 
+have been unified, we'll find that when we canonicalise it, and the 
+t1~t2 information may be crucial (Trac #8705 is an example).
+
+If it turns out that k1 and k2 are really un-equal, then it'll end up
+as an Irreducible (see Note [Equalities with incompatible kinds] in
+TcCanonical), and will do no harm.
+
 \begin{code}
 xCtEvidence :: CtEvidence            -- Original flavor
             -> XEvTerm               -- Instructions about how to manipulate evidence
@@ -1677,8 +1683,8 @@ xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc })
   where
     -- See Note [Do not create Given kind equalities]
     bad_given_pred (pred_ty, _)
-      | EqPred t1 t2 <- classifyPredType pred_ty
-      = isKind t1 || not (typeKind t1 `tcEqKind` typeKind t2)
+      | EqPred t1 _ <- classifyPredType pred_ty
+      = isKind t1
       | otherwise
       = False
 
diff --git a/testsuite/tests/polykinds/T8705.hs b/testsuite/tests/polykinds/T8705.hs
new file mode 100644
index 0000000..d066f21
--- /dev/null
+++ b/testsuite/tests/polykinds/T8705.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeOperators, DataKinds, PolyKinds,
+             MultiParamTypeClasses, GADTs, ConstraintKinds, TypeFamilies #-}
+module T8705 where
+
+data family Sing (a :: k)
+data Proxy a = Proxy
+
+data instance Sing (a :: Maybe k) where
+  SJust :: Sing h -> Sing (Just h)
+
+data Dict c where
+  Dict :: c => Dict c
+
+-- A less-than-or-equal relation among naturals
+class a :<=: b
+
+sLeq :: Sing n -> Sing n2 -> Dict (n :<=: n2)
+sLeq = undefined
+
+insert_ascending :: (lst ~ Just n1) => Proxy n1 -> Sing n -> Sing lst -> Dict (n :<=: n1)
+insert_ascending _ n (SJust h)
+  = case sLeq n h of
+      Dict -> Dict
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index 005c47a..8dc1181 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -98,3 +98,4 @@ test('T8566', normal, compile_fail,[''])
 test('T8616', normal, compile_fail,[''])
 test('T8566a', expect_broken(8566), compile,[''])
 test('T7481', normal, compile_fail,[''])
+test('T8705', normal, compile, [''])