Support wild cards in data/type family instances

Handle anonymous wild cards in type or data family instance
declarations like
unnamed type variables. For instance (pun intented):

    type family F (a :: *) (b :: *) :: *
    type instance F Int _ = Int

Is now the same as:

    type family F (a :: *) (b :: *) :: *
    type instance F Int x = Int

Note that unlike wild cards in partial type signatures, no errors (or
warnings
with -XPartialTypeSignatures) are generated for these wild cards, as
there is
nothing interesting to report to the user, i.e. the inferred kind.

Only anonymous wild cards are supported here, named and
extra-constraints wild
card are not.

Test Plan: pass new tests

Reviewers: goldfire, austin, simonpj, bgamari

Reviewed By: simonpj, bgamari

Subscribers: goldfire, thomie

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

GHC Trac Issues: #3699, #10586

12 files changed, 78 insertions, 15 deletions

diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.hs
new file mode 100644
index 0000000000..68541b8588
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-}
+module DataFamilyInstanceLHS where
+-- Test case from #10586
+data MyKind = A | B
+
+data family Sing (a :: k)
+
+data instance Sing (_ :: MyKind) where
+    SingA :: Sing A
+    SingB :: Sing B
+
+foo :: Sing A
+foo = SingA
diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
new file mode 100644
index 0000000000..6ca37a9434
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
@@ -0,0 +1,16 @@
+TYPE SIGNATURES
+  foo :: Sing 'A
+TYPE CONSTRUCTORS
+  data MyKind = A | B
+    Promotable
+  type role Sing nominal
+  data family Sing (a :: k)
+    RecFlag: Recursive
+COERCION AXIOMS
+  axiom DataFamilyInstanceLHS.TFCo:R:SingMyKind_ ::
+      Sing = DataFamilyInstanceLHS.R:SingMyKind_
+FAMILY INSTANCES
+  data instance Sing
+Dependent modules: []
+Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
+                     integer-gmp-1.0.0.0]
diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.hs
new file mode 100644
index 0000000000..c3172b7cd0
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+module TypeFamilyInstanceLHS where
+
+type family F (a :: *) (b :: *) :: *
+type instance F Int  _ = Int
+type instance F Bool _ = Bool
+
+foo :: F Int Char -> Int
+foo = id
diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
new file mode 100644
index 0000000000..b2ead26a95
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
@@ -0,0 +1,13 @@
+TYPE SIGNATURES
+  foo :: F Int Char -> Int
+TYPE CONSTRUCTORS
+  type family F a b :: * open
+COERCION AXIOMS
+  axiom TypeFamilyInstanceLHS.TFCo:R:FBool_ :: F Bool _ = Bool
+  axiom TypeFamilyInstanceLHS.TFCo:R:FInt_ :: F Int _ = Int
+FAMILY INSTANCES
+  type instance F Int _
+  type instance F Bool _
+Dependent modules: []
+Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
+                     integer-gmp-1.0.0.0]
diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T
index 5597183712..9e7b8a75e8 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -6,6 +6,7 @@ test('AddAndOr4', normal, compile, ['-ddump-types -fno-warn-partial-type-signatu
 test('AddAndOr5', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('AddAndOr6', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('BoolToBool', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
+test('DataFamilyInstanceLHS', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('Defaulting1MROn', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('Defaulting2MROff', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('Defaulting2MROn', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
@@ -43,6 +44,7 @@ test('ShowNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatu
 test('SimpleGen', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('SkipMany', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('SomethingShowable', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
+test('TypeFamilyInstanceLHS', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('Uncurry', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('UncurryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('WarningWildcardInstantiations', normal, compile, ['-ddump-types'])
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.hs
new file mode 100644
index 0000000000..65bad72c39
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-}
+module NamedWildcardInDataFamilyInstanceLHS where
+
+data MyKind = A | B
+
+data family Sing (a :: k)
+
+data instance Sing (_a :: MyKind) where
+    SingA :: Sing A
+    SingB :: Sing B
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr
new file mode 100644
index 0000000000..f97cdc3f4d
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr
@@ -0,0 +1,4 @@
+
+NamedWildcardInDataFamilyInstanceLHS.hs:8:21: error:
+    Unexpected wild card: ‘_a’
+    In the data type declaration for ‘Sing’
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.hs
new file mode 100644
index 0000000000..dabd781af8
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE NamedWildCards #-}
+module NamedWildcardInTypeFamilyInstanceLHS where
+
+type family F a where
+  F _t = Int
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr
new file mode 100644
index 0000000000..550f6ceb2e
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr
@@ -0,0 +1,4 @@
+
+NamedWildcardInTypeFamilyInstanceLHS.hs:5:5: error:
+    Unexpected wild card: ‘_t’
+    In the declaration for type synonym ‘F’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs
deleted file mode 100644
index 3fca6bc7a2..0000000000
--- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# LANGUAGE PartialTypeSignatures, TypeFamilies, InstanceSigs #-}
-module WildcardInTypeFamilyInstanceLHS where
-
-class Foo k where
-  type Dual k :: *
-
-instance Foo Int where
-  type Dual _ = Maybe Int
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr
deleted file mode 100644
index fda3e6b0ac..0000000000
--- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceLHS.stderr
+++ /dev/null
@@ -1,6 +0,0 @@
-
-WildcardInTypeFamilyInstanceLHS.hs:8:13:
-    Unexpected wild card: ‘_’
-    In the type ‘_’
-    In the type instance declaration for ‘Dual’
-    In the instance declaration for ‘Foo Int’
diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T
index 9417a3ed8f..8f0b0a0f77 100644
--- a/testsuite/tests/partial-sigs/should_fail/all.T
+++ b/testsuite/tests/partial-sigs/should_fail/all.T
@@ -20,6 +20,8 @@ test('InstantiatedNamedWildcardsInConstraints', normal, compile_fail, [''])
 test('NamedExtraConstraintsWildcard', normal, compile_fail, [''])
 test('NamedWildcardInTypeSplice', normal, compile_fail, [''])
 test('NamedWildcardsEnabled', normal, compile_fail, [''])
+test('NamedWildcardInDataFamilyInstanceLHS', normal, compile_fail, [''])
+test('NamedWildcardInTypeFamilyInstanceLHS', normal, compile_fail, [''])
 test('NamedWildcardsNotEnabled', normal, compile_fail, [''])
 test('NamedWildcardsNotInMonotype', normal, compile_fail, [''])
 test('NestedExtraConstraintsWildcard', normal, compile_fail, [''])
@@ -53,7 +55,6 @@ test('WildcardInPatSynSig', normal, compile_fail, [''])
 test('WildcardInNewtype', normal, compile_fail, [''])
 test('WildcardInStandaloneDeriving', normal, compile_fail, [''])
 test('WildcardInstantiations', normal, compile_fail, [''])
-test('WildcardInTypeFamilyInstanceLHS', normal, compile_fail, [''])
 test('WildcardInTypeFamilyInstanceRHS', normal, compile_fail, [''])
 test('WildcardInTypeSynonymLHS', normal, compile_fail, [''])
 test('WildcardInTypeSynonymRHS', normal, compile_fail, [''])