Allow type defaulting for multi-param type classes with ExtendedDefaultRules

Expressions like the following will now typecheck:

```
    data A x = A deriving Show

    class ToA a x where
       toA :: a -> A x

    instance ToA Integer x where
       toA _ = A

    main = print (toA 5 :: A Bool)
```

The new defaulting rules are

Find all the unsolved constraints. Then:

* Find those that have exactly one free type variable, and partition
  that subset into groups that share a common type variable `a`.
* Now default `a` (to one of the types in the default list) if at least
  one of the classes `Ci` is an interactive class

Reviewers: goldfire, bgamari, austin, mpickering, simonpj

Reviewed By: bgamari, simonpj

Subscribers: mpickering, simonpj, goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2822

7 files changed, 117 insertions, 6 deletions

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 61f2c12543..ee07e845b6 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -2019,6 +2019,7 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
         -- Finds unary type-class constraints
         -- But take account of polykinded classes like Typeable,
         -- which may look like (Typeable * (a:*))   (Trac #8931)
+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct
     find_unary cc
         | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
         , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys
@@ -2034,11 +2035,13 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
 
     cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
 
+    defaultable_tyvar :: TcTyVar -> Bool
     defaultable_tyvar tv
         = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]
               b2 = not (tv `elemVarSet` bad_tvs)
-          in b1 && b2
+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]
 
+    defaultable_classes :: [Class] -> Bool
     defaultable_classes clss
         | extended_defaults = any (isInteractiveClass ovl_strings) clss
         | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)
@@ -2125,4 +2128,28 @@ that g isn't polymorphic enough; but then we get another one when
 dealing with the (Num a) context arising from f's definition;
 we try to unify a with Int (to default it), but find that it's
 already been unified with the rigid variable from g's type sig.
+
+Note [Multi-parameter defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XExtendedDefaultRules, we default only based on single-variable
+constraints, but do not exclude from defaulting any type variables which also
+appear in multi-variable constraints. This means that the following will
+default properly:
+
+   default (Integer, Double)
+
+   class A b (c :: Symbol) where
+      a :: b -> Proxy c
+
+   instance A Integer c where a _ = Proxy
+
+   main = print (a 5 :: Proxy "5")
+
+Note that if we change the above instance ("instance A Integer") to
+"instance A Double", we get an error:
+
+   No instance for (A Integer "5")
+
+This is because the first defaulted type (Integer) has successfully satisfied
+its single-parameter constraints (in this case Num).
 -}
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index 00e6c7c4b5..d70dc50e42 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -154,6 +154,9 @@ Compiler
   allocation and a potential space leak when deriving ``Functor`` for
   a recursive type.
 
+- The :ghc-flag:`-XExtendedDefaultRules` extension now defaults multi-parameter
+  typeclasses. See :ghc-ticket:`12923`.
+
 GHCi
 ~~~~
 
diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst
index fa00b80244..04864cda83 100644
--- a/docs/users_guide/ghci.rst
+++ b/docs/users_guide/ghci.rst
@@ -1040,17 +1040,27 @@ and defaults the type variable if
 3. At least one of the classes ``Ci`` is numeric.
 
 At the GHCi prompt, or with GHC if the :ghc-flag:`-XExtendedDefaultRules` flag
-is given, the following additional differences apply:
+is given, the types are instead resolved with the following method:
 
--  Rule 2 above is relaxed thus: *All* of the classes ``Ci`` are
-   single-parameter type classes.
+Find all the unsolved constraints. Then:
 
--  Rule 3 above is relaxed thus: At least one of the classes ``Ci`` is
-   an *interactive class* (defined below).
+-  Find those that are of form ``(C a)`` where ``a`` is a type variable, and
+   partition those constraints into groups that share a common type variable ``a``.
+
+-  Keep only the groups in which at least one of the classes is an
+   **interactive class** (defined below).
+
+-  Now, for each remaining group G, try each type ``ty`` from the default-type list
+   in turn; if setting ``a = ty`` would allow the constraints in G to be completely
+   solved. If so, default ``a`` to ``ty``.
 
 -  The unit type ``()`` and the list type ``[]`` are added to the start of
    the standard list of types which are tried when doing type defaulting.
 
+Note that any multi-parameter constraints ``(D a b)`` or ``(D [a] Int)`` do not
+participate in the process (either to help or to hinder); but they must of course
+be soluble once the defaulting process is complete.
+
 The last point means that, for example, this program: ::
 
     main :: IO ()
diff --git a/testsuite/tests/typecheck/should_compile/T12923.hs b/testsuite/tests/typecheck/should_compile/T12923.hs
new file mode 100644
index 0000000000..bd3f55df54
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12923.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+
+module T12923 where
+
+-- Test that ExtendedDefaultRules defaults multiparameter typeclasses with only
+-- one parameter of kind Type.
+class Works a (b :: Bool) where
+   works :: a -> A b
+
+data A (b :: Bool) = A deriving Show
+
+instance Works Integer 'True where works _ = A
+
+main :: IO ()
+main = print (works 5 :: A 'True)
diff --git a/testsuite/tests/typecheck/should_compile/T12924.hs b/testsuite/tests/typecheck/should_compile/T12924.hs
new file mode 100644
index 0000000000..573abc448b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12924.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+module T12924 where
+
+import GHC.TypeLits
+
+data A (b :: [Symbol]) = A deriving Show
+
+-- Test that ExtendedDefaultRules defaults multiparameter typeclasses with only
+-- one parameter of kind Type.
+class Works a (b :: [Symbol]) where
+   works :: a -> A b
+
+instance Works Integer a where
+   works _ = A
+
+main :: IO ()
+main = print (addA (works 5) (works 10)) -- :: A '[])
+
+-- | Note argument types aren't concrete
+addA :: A a -> A a -> A '[]
+addA A A = A
diff --git a/testsuite/tests/typecheck/should_compile/T12926.hs b/testsuite/tests/typecheck/should_compile/T12926.hs
new file mode 100644
index 0000000000..8f9f5df649
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12926.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+module T12926 where
+
+import GHC.TypeLits
+
+data A (b :: [Symbol]) = A deriving Show
+
+class Works a (b :: [Symbol]) where
+   works :: a -> A b
+
+instance Works Integer a where
+   works _ = A
+
+addA :: A a -> A a -> A a
+addA A A = A
+
+test2 :: A x -- Note this is able to have a polymorphic type
+test2 = addA (works 5) (works 5)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 286ebbb1ea..c44ab9153c 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -539,3 +539,6 @@ test('T13248', expect_broken(13248), compile, [''])
 test('T11525', [unless(have_dynamic(), expect_broken(10301))], multi_compile,
      ['', [('T11525_Plugin.hs', '-package ghc'), ('T11525.hs', '')],
       '-dynamic'])
+test('T12923', normal, compile, [''])
+test('T12924', normal, compile, [''])
+test('T12926', normal, compile, [''])