Fix solving of implicit parameter constraints

Trac #14218 showed that we were not solving implicit-parameter
constraints correctly.  In particular,

- A tuple constraint could "hide" an implicit-parameter wanted
  constraint, and that in turn could that we solved it from the
  wrong implicit-parameter binding.

- As a special case the HasCallStack constraint (which is just
  short for (IP "callStack" CallStack), was getting mis-solved.

The big change is to arrange that, in TcSMonad.findDict when looking
for a dictionary, either when looking for a matching inert or solved
dictionary, we fail for

  - Tuples that are hiding implicit parameters
    See Note [Tuples hiding implicit parameters]

  - HasCallStack constraints where we have not yet pushed
    on the call-site info
    See Note [Solving CallStack constraints]

I also did a little refactoring

* Move naturallyCoherentClass from Class to TcInteract, its sole
  use site.  Class.hs seems like the wrong place.  (And I also
  do not understand the reason that we need the eq/Coercible/
  Typable stuff in this predicate, but I'll tackle that separately.)

* Move the code that pushes call-site info onto a call stack
  from the "interact" part to the "canonicalise" part of the solver.

3 files changed, 37 insertions, 0 deletions

diff --git a/testsuite/tests/typecheck/should_run/T14218.hs b/testsuite/tests/typecheck/should_run/T14218.hs
new file mode 100644
index 0000000000..061700e083
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T14218.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ConstraintKinds #-}       -- For 'C'
+{-# LANGUAGE MultiParamTypeClasses #-} -- For nullary 'Trivial' class
+{-# LANGUAGE ImplicitParams #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+module Main where
+
+import qualified GHC.Stack as Ghc
+
+class Trivial where
+instance Trivial where
+
+type C = (Ghc.HasCallStack, Trivial)
+
+-- | Print the functions on the call stack.
+callStack :: C => IO ()
+callStack = print $ map fst (Ghc.getCallStack Ghc.callStack)
+
+f :: C => a -> IO ()
+f x = callStack
+
+type C2 =  (?x::Int, ?y::Int)
+
+h1 :: C2 => Int -> IO ()
+h1 v = print (?x+v)
+
+h2 :: C2 => Int -> IO ()
+h2 v = let ?x = 0 in h1 v
+
+main = do { let { ?x = 3; ?y = 4 }  in h2 4
+            -- Should print 4+0 = 4
+
+          ; f "ugh"
+            -- Should print @["callStack", "f"]@.
+          }
diff --git a/testsuite/tests/typecheck/should_run/T14218.stdout b/testsuite/tests/typecheck/should_run/T14218.stdout
new file mode 100644
index 0000000000..f446c88ee9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T14218.stdout
@@ -0,0 +1,2 @@
+4
+["callStack","f"]
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 3fc1928d4a..3d1aa36546 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -123,3 +123,4 @@ test('TypeableEq', normal, compile_and_run, [''])
 test('T13435', normal, compile_and_run, [''])
 test('T11715', exit_code(1), compile_and_run, [''])
 test('T13594a', normal, ghci_script, ['T13594a.script'])
+test('T14218', normal, compile_and_run, [''])