Support constraint synonym implementations of abstract classes.

Summary:

Test Plan: validate

Reviewers: goldfire, simonpj, austin, bgamari

Subscribers: thomie

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

GHC Trac Issues: #12679

5 files changed, 91 insertions, 0 deletions

diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T
index c9ba076828..7238b636ef 100644
--- a/testsuite/tests/backpack/should_compile/all.T
+++ b/testsuite/tests/backpack/should_compile/all.T
@@ -31,3 +31,5 @@ test('bkp35', expect_broken(0), backpack_compile, [''])
 test('bkp36', normal, backpack_compile, [''])
 test('bkp37', normal, backpack_compile, [''])
 test('bkp38', normal, backpack_compile, [''])
+test('bkp39', normal, backpack_compile, [''])
+test('bkp40', normal, backpack_compile, [''])
diff --git a/testsuite/tests/backpack/should_compile/bkp39.bkp b/testsuite/tests/backpack/should_compile/bkp39.bkp
new file mode 100644
index 0000000000..45f680e94f
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp39.bkp
@@ -0,0 +1,17 @@
+{-# LANGUAGE ConstraintKinds #-}
+unit p where
+    signature A where
+        import Prelude hiding ((==))
+        class K a
+        class K2 a
+        (==) :: K a => a -> a -> Bool
+    module M where
+        import Prelude hiding ((==))
+        import A
+        f a b c = a == b && b == c
+unit q where
+    module A(K, K2, (==)) where
+        type K a = Eq a
+        type K2 = Eq
+unit r where
+    dependency p[A=q:A]
diff --git a/testsuite/tests/backpack/should_compile/bkp39.stderr b/testsuite/tests/backpack/should_compile/bkp39.stderr
new file mode 100644
index 0000000000..924785c9da
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp39.stderr
@@ -0,0 +1,12 @@
+[1 of 3] Processing p
+  [1 of 2] Compiling A[sig]           ( p/A.hsig, nothing )
+  [2 of 2] Compiling M                ( p/M.hs, nothing )
+[2 of 3] Processing q
+  Instantiating q
+  [1 of 1] Compiling A                ( q/A.hs, bkp39.out/q/A.o )
+[3 of 3] Processing r
+  Instantiating r
+  [1 of 1] Including p[A=q:A]
+    Instantiating p[A=q:A]
+    [1 of 2] Compiling A[sig]           ( p/A.hsig, bkp39.out/p/p-HVmFlcYSefiK5n1aDP1v7x/A.o )
+    [2 of 2] Compiling M                ( p/M.hs, bkp39.out/p/p-HVmFlcYSefiK5n1aDP1v7x/M.o )
diff --git a/testsuite/tests/backpack/should_compile/bkp40.bkp b/testsuite/tests/backpack/should_compile/bkp40.bkp
new file mode 100644
index 0000000000..3f97456686
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp40.bkp
@@ -0,0 +1,41 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RoleAnnotations #-}
+unit user where
+    signature Map where
+        type role Map nominal representational
+        data Map k a
+        class Key k
+        instance Key String
+        empty  :: Map k a
+        lookup :: Key k => k -> Map k a -> Maybe a
+        insert :: Key k => k -> a -> Map k a -> Map k a
+    module User where
+        import Prelude hiding (lookup)
+        import Map
+        x = lookup "foo" (insert "foo" True empty)
+unit ordmap where
+    module Map(module Data.Map, Key) where
+        import Data.Map
+        type Key = Ord
+unit eqmap where
+    module Map where
+        import Prelude hiding (lookup)
+        import qualified Prelude
+        type role Map nominal representational
+        newtype Map k a = Assoc [(k, a)]
+        type Key = Eq
+        -- Ugh, need the type signatures, otherwise the quantifiers
+        -- are put in the wrong order.  See #12441
+        empty :: Map k a
+        empty = Assoc []
+        lookup :: Eq k => k -> Map k a -> Maybe a
+        lookup k (Assoc xs) = Prelude.lookup k xs
+        -- Need to insert redundant constraint to make it work...
+        insert :: Eq k => k -> a -> Map k a -> Map k a
+        insert k v (Assoc xs) = Assoc ((k,v):xs)
+unit main where
+    dependency user[Map=ordmap:Map] (User as User.Ord)
+    dependency user[Map=eqmap:Map] (User as User.Eq)
+
diff --git a/testsuite/tests/backpack/should_compile/bkp40.stderr b/testsuite/tests/backpack/should_compile/bkp40.stderr
new file mode 100644
index 0000000000..00176aabd2
--- /dev/null
+++ b/testsuite/tests/backpack/should_compile/bkp40.stderr
@@ -0,0 +1,19 @@
+[1 of 4] Processing user
+  [1 of 2] Compiling Map[sig]         ( user/Map.hsig, nothing )
+  [2 of 2] Compiling User             ( user/User.hs, nothing )
+[2 of 4] Processing ordmap
+  Instantiating ordmap
+  [1 of 1] Compiling Map              ( ordmap/Map.hs, bkp40.out/ordmap/Map.o )
+[3 of 4] Processing eqmap
+  Instantiating eqmap
+  [1 of 1] Compiling Map              ( eqmap/Map.hs, bkp40.out/eqmap/Map.o )
+[4 of 4] Processing main
+  Instantiating main
+  [1 of 2] Including user[Map=ordmap:Map]
+    Instantiating user[Map=ordmap:Map]
+    [1 of 2] Compiling Map[sig]         ( user/Map.hsig, bkp40.out/user/user-GzloW2NeDdA2M0V8qzN4g2/Map.o )
+    [2 of 2] Compiling User             ( user/User.hs, bkp40.out/user/user-GzloW2NeDdA2M0V8qzN4g2/User.o )
+  [2 of 2] Including user[Map=eqmap:Map]
+    Instantiating user[Map=eqmap:Map]
+    [1 of 2] Compiling Map[sig]         ( user/Map.hsig, bkp40.out/user/user-9YyTxEeqz3GG5thfDXwuAf/Map.o )
+    [2 of 2] Compiling User             ( user/User.hs, bkp40.out/user/user-9YyTxEeqz3GG5thfDXwuAf/User.o )