From c1e24faa9579dd4b50a46c65ebe3f3a292139422 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Fri, 8 Jan 2021 11:57:32 +0100
Subject: Improve defaulting detection code

As suggested at https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4701#note_322397
This makes sure that the code does not create an ill-kinded type.
---
 compiler/GHC/Tc/Errors.hs      | 1 -
 compiler/GHC/Tc/Gen/Default.hs | 9 +++++----
 compiler/GHC/Tc/Solver.hs      | 5 ++---
 3 files changed, 7 insertions(+), 8 deletions(-)

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 4f7c9dfea2..fe4e5a341f 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -167,7 +167,6 @@ reportUnsolved wanted
 -- See Note [Deferring coercion errors to runtime]
 -- Used by solveEqualities for kind equalities
 --      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")
--- and for simplifyDefault.
 reportAllUnsolved :: WantedConstraints -> TcM ()
 reportAllUnsolved wanted
   = do { ev_binds <- newNoTcEvBinds
diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs
index d37f26df40..0a50f3e983 100644
--- a/compiler/GHC/Tc/Gen/Default.hs
+++ b/compiler/GHC/Tc/Gen/Default.hs
@@ -12,6 +12,7 @@ import GHC.Prelude
 
 import GHC.Hs
 import GHC.Core.Class
+import GHC.Core.Type (typeKind)
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Env
 import GHC.Tc.Gen.HsType
@@ -85,10 +86,10 @@ check_instance :: Type -> Class -> TcM Bool
   -- Check that ty is an instance of cls
   -- We only care about whether it worked or not; return a boolean
 check_instance ty cls
-  = do  { (_, success) <- discardErrs $
-                          askNoErrs $
-                          simplifyDefault [mkClassPred cls [ty]]
-        ; return success }
+  | eqType (typeKind $ mkTyConTy $ classTyCon cls)
+           (mkVisFunTyMany (typeKind ty) constraintKind)
+     = simplifyDefault [mkClassPred cls [ty]]
+  | otherwise = return False
 
 defaultDeclCtxt :: SDoc
 defaultDeclCtxt = text "When checking the types in a default declaration"
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 991708111d..3a5d771a88 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -757,13 +757,12 @@ simplifyInteractive wanteds
 
 ------------------
 simplifyDefault :: ThetaType    -- Wanted; has no type variables in it
-                -> TcM ()       -- Succeeds if the constraint is soluble
+                -> TcM Bool     -- Return if the constraint is soluble
 simplifyDefault theta
   = do { traceTc "simplifyDefault" empty
        ; wanteds  <- newWanteds DefaultOrigin theta
        ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))
-       ; reportAllUnsolved unsolved
-       ; return () }
+       ; return (isEmptyWC unsolved) }
 
 ------------------
 tcCheckSatisfiability :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)
-- 
cgit v1.2.1