Associate pattern synonyms with types in module exports

This patch implements #10653.

It adds the ability to bundle pattern synonyms with type constructors in
export lists so that users can treat pattern synonyms more like data
constructors.

Updates haddock submodule.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: simonpj, gridaphobe, thomie

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

GHC Trac Issues: #10653

30 files changed, 301 insertions, 0 deletions

diff --git a/testsuite/tests/patsyn/should_compile/Associated.hs b/testsuite/tests/patsyn/should_compile/Associated.hs
new file mode 100644
index 0000000000..b4ea94922d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/Associated.hs
@@ -0,0 +1,9 @@
+module Associated(A(..)) where
+
+import AssociatedInternal (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/testsuite/tests/patsyn/should_compile/Associated1.hs b/testsuite/tests/patsyn/should_compile/Associated1.hs
new file mode 100644
index 0000000000..fce00b3850
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/Associated1.hs
@@ -0,0 +1,9 @@
+module Associated1(A(..)) where
+
+import AssociatedInternal1 (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/testsuite/tests/patsyn/should_compile/AssociatedInternal.hs b/testsuite/tests/patsyn/should_compile/AssociatedInternal.hs
new file mode 100644
index 0000000000..b3e6506651
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/AssociatedInternal.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module AssociatedInternal (A(NewA,MkA, NoA)) where
+
+newtype A = NewA (Maybe Int)
+
+pattern MkA n = NewA (Just n)
+
+pattern NoA = NewA Nothing
diff --git a/testsuite/tests/patsyn/should_compile/AssociatedInternal1.hs b/testsuite/tests/patsyn/should_compile/AssociatedInternal1.hs
new file mode 100644
index 0000000000..7997d1db21
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/AssociatedInternal1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module AssociatedInternal1 (A(NewA,MkA, NoA)) where
+
+newtype A = NewA (Maybe Int)
+
+pattern MkA n = NewA (Just n)
+
+pattern NoA = NewA Nothing
diff --git a/testsuite/tests/patsyn/should_compile/ExportSyntax.hs b/testsuite/tests/patsyn/should_compile/ExportSyntax.hs
new file mode 100644
index 0000000000..7c50cf468e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ExportSyntax.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where
+
+data A = A | B
+
+pattern NoA = B
+
+data Q a = Q a
+
+pattern F a = Q a
+
+data G = G | H
+
+pattern T = G
+
+pattern U = H
diff --git a/testsuite/tests/patsyn/should_compile/ExportSyntaxImport.hs b/testsuite/tests/patsyn/should_compile/ExportSyntaxImport.hs
new file mode 100644
index 0000000000..ad2b381d73
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ExportSyntaxImport.hs
@@ -0,0 +1,7 @@
+module ExportSyntaxImport where
+
+import ExportSyntax
+
+foo = NoA
+
+baz = A
diff --git a/testsuite/tests/patsyn/should_compile/TransAssociated.hs b/testsuite/tests/patsyn/should_compile/TransAssociated.hs
new file mode 100644
index 0000000000..a5fbe0c0bb
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/TransAssociated.hs
@@ -0,0 +1,9 @@
+module TransAssociated(A(..)) where
+
+import Associated (A(..))
+
+foo = MkA 5
+baz = NoA
+
+qux (MkA x) = x
+qux NoA = 0
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 19dbd75c4e..7160a8128d 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -33,3 +33,15 @@ test('records-poly', normal, compile, [''])
 test('records-req', normal, compile, [''])
 test('records-prov-req', normal, compile, [''])
 test('records-req-only', normal, compile, [''])
+test('Associated', [extra_clean(['AssociatedInternal1.hi', 'AssociatedInternal1.o'])], multimod_compile, ['Associated1', '-v0'])
+test('TransAssociated', [extra_clean(['Associated.hi', 'Associated.o', 'AssociatedInternal.hi', 'AssociatedInternal.o'])], multimod_compile, ['TransAssociated', '-v0'])
+test('ExportSyntax', normal, compile, [''])
+test('ExportSyntaxImport', [extra_clean(['ExportSyntax.hi', 'ExportSyntax.o'])], multimod_compile, ['ExportSyntaxImport', '-v0'])
+test('poly-export', normal, compile, [''])
+test('poly-export2', normal, compile, [''])
+test('poly-export3', normal, compile, [''])
+test('multi-export', normal, compile, [''])
+test('export-super-class', normal, compile, [''])
+test('export-record-selector', normal, compile, [''])
+
+
diff --git a/testsuite/tests/patsyn/should_compile/export-record-selector.hs b/testsuite/tests/patsyn/should_compile/export-record-selector.hs
new file mode 100644
index 0000000000..780e1babbf
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/export-record-selector.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo ( A(foo) ) where
+
+data A a = A a
+
+pattern P :: Int -> A Int
+pattern P{foo} = A foo
diff --git a/testsuite/tests/patsyn/should_compile/export-super-class.hs b/testsuite/tests/patsyn/should_compile/export-super-class.hs
new file mode 100644
index 0000000000..5dcee61fbe
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/export-super-class.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Foo ( A(P) ) where
+
+class (f ~ A) => C f a where
+  build :: a -> f a
+  destruct :: f a -> a
+
+data A a = A a
+
+instance C A Int where
+  build n = A n
+  destruct (A n) = n
+
+
+pattern P :: C f a => a -> f a
+pattern P x <- (destruct -> x)
+  where
+        P x = build x
diff --git a/testsuite/tests/patsyn/should_compile/multi-export.hs b/testsuite/tests/patsyn/should_compile/multi-export.hs
new file mode 100644
index 0000000000..4fffd77b0c
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/multi-export.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo (A(B, C)) where
+
+data A a = A
+
+pattern B :: A Int
+pattern B = A
+
+pattern C :: A String
+pattern C = A
diff --git a/testsuite/tests/patsyn/should_compile/poly-export.hs b/testsuite/tests/patsyn/should_compile/poly-export.hs
new file mode 100644
index 0000000000..b4cff98de5
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/poly-export.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Foo (Foo(P)) where
+
+data Foo a = Foo a
+
+instance C Foo where
+  build a = Foo a
+  destruct (Foo a) = a
+
+class C f where
+  build :: a -> f a
+  destruct :: f a -> a
+
+pattern P :: C f => a -> f a
+pattern P x <- (destruct -> x)
+  where
+        P x = build x
diff --git a/testsuite/tests/patsyn/should_compile/poly-export2.hs b/testsuite/tests/patsyn/should_compile/poly-export2.hs
new file mode 100644
index 0000000000..cfea9985f8
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/poly-export2.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Foo (A(P,Q)) where
+
+data A a = A a
+
+pattern P :: Show a => a -> A a
+pattern P a = A a
+
+pattern Q :: (A ~ f) => a -> f a
+pattern Q a = A a
diff --git a/testsuite/tests/patsyn/should_compile/poly-export3.hs b/testsuite/tests/patsyn/should_compile/poly-export3.hs
new file mode 100644
index 0000000000..0141059d2b
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/poly-export3.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+
+-- Testing polykindedness
+
+module Foo ( A(P) ) where
+
+data A a = A
+
+pattern P = A
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 7e3446f1f5..d5ebca9cf3 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -17,3 +17,11 @@ test('records-exquant', normal, compile_fail, [''])
 test('records-poly-update', normal, compile_fail, [''])
 test('mixed-pat-syn-record-sels', normal, compile_fail, [''])
 test('T11039', [expect_broken(11039)], compile_fail, [''])
+test('export-type', normal, compile_fail, [''])
+test('export-syntax', normal, compile_fail, [''])
+test('import-syntax', normal, compile_fail, [''])
+test('export-class', normal, compile_fail, [''])
+test('poly-export-fail2', expect_broken(10653), compile_fail, [''])
+test('export-super-class-fail', expect_broken(10653), compile_fail, [''])
+test('export-type-synonym', normal, compile_fail, [''])
+test('export-ps-rec-sel', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/export-class.hs b/testsuite/tests/patsyn/should_fail/export-class.hs
new file mode 100644
index 0000000000..b9183e0a3d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-class.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo (MyClass(.., P)) where
+
+pattern P = Nothing
+
+class MyClass a where
+  foo :: a -> Int
diff --git a/testsuite/tests/patsyn/should_fail/export-class.stderr b/testsuite/tests/patsyn/should_fail/export-class.stderr
new file mode 100644
index 0000000000..15be2deaf4
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-class.stderr
@@ -0,0 +1,4 @@
+
+export-class.hs:3:13: error:
+    Pattern synonyms can be bundled only with datatypes.
+    In the export: MyClass(.., P)
diff --git a/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.hs b/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.hs
new file mode 100644
index 0000000000..1e91695631
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo( R(P,x)) where
+
+data Q = Q Int
+
+data R = R
+
+pattern P{x} = Q x
diff --git a/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.stderr b/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.stderr
new file mode 100644
index 0000000000..7ba9a42000
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-ps-rec-sel.stderr
@@ -0,0 +1,12 @@
+
+export-ps-rec-sel.hs:2:13: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘R’ with actual type of ‘Q’
+    In the pattern synonym: P
+    In the export: R(P, x)
+
+export-ps-rec-sel.hs:2:13: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘R’ with actual type of ‘Q’
+    In the pattern synonym record selector: x
+    In the export: R(P, x)
diff --git a/testsuite/tests/patsyn/should_fail/export-super-class-fail.hs b/testsuite/tests/patsyn/should_fail/export-super-class-fail.hs
new file mode 100644
index 0000000000..c7ba73aee1
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-super-class-fail.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Foo ( B(P) ) where
+
+class (f ~ A) => C f a where
+  build :: a -> f a
+  destruct :: f a -> a
+
+data A a = A a
+
+data B a = B a
+
+instance C A Int where
+  build n = A n
+  destruct (A n) = n
+
+
+pattern P :: C f a => a -> f a
+pattern P x <- (destruct -> x)
+  where
+        P x = build x
diff --git a/testsuite/tests/patsyn/should_fail/export-syntax.hs b/testsuite/tests/patsyn/should_fail/export-syntax.hs
new file mode 100644
index 0000000000..523a01d254
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-syntax.hs
@@ -0,0 +1,3 @@
+module Foo(A(.., B)) where
+
+data A = A | B
diff --git a/testsuite/tests/patsyn/should_fail/export-syntax.stderr b/testsuite/tests/patsyn/should_fail/export-syntax.stderr
new file mode 100644
index 0000000000..8843a6a395
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-syntax.stderr
@@ -0,0 +1,3 @@
+
+export-syntax.hs:1:12: error:
+    Illegal export form (use PatternSynonyms to enable)
diff --git a/testsuite/tests/patsyn/should_fail/export-type-synonym.hs b/testsuite/tests/patsyn/should_fail/export-type-synonym.hs
new file mode 100644
index 0000000000..3f32515217
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-type-synonym.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo ( A(P) ) where
+
+data A = A
+data B = B
+
+type C = B
+
+pattern P :: C
+pattern P = B
diff --git a/testsuite/tests/patsyn/should_fail/export-type-synonym.stderr b/testsuite/tests/patsyn/should_fail/export-type-synonym.stderr
new file mode 100644
index 0000000000..d136d6e1c3
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-type-synonym.stderr
@@ -0,0 +1,6 @@
+
+export-type-synonym.hs:3:14: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘A’ with actual type of ‘C’
+    In the pattern synonym: P
+    In the export: A(P)
diff --git a/testsuite/tests/patsyn/should_fail/export-type.hs b/testsuite/tests/patsyn/should_fail/export-type.hs
new file mode 100644
index 0000000000..9853637ca0
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-type.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Export (A(..,MyB), B(MyA), C(MyC)) where
+
+data A = A
+
+data B = B
+
+pattern MyB = B
+
+pattern MyA = A
+
+data C a = C
+
+pattern MyC = B
diff --git a/testsuite/tests/patsyn/should_fail/export-type.stderr b/testsuite/tests/patsyn/should_fail/export-type.stderr
new file mode 100644
index 0000000000..9ad622eefb
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/export-type.stderr
@@ -0,0 +1,18 @@
+
+export-type.hs:3:16: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘A’ with actual type of ‘B’
+    In the pattern synonym: MyB
+    In the export: A(.., MyB)
+
+export-type.hs:3:27: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘B’ with actual type of ‘A’
+    In the pattern synonym: MyA
+    In the export: B(MyA)
+
+export-type.hs:3:35: error:
+    Pattern synonyms can only be bundled with matching type constructors
+    Couldn't match expected type of ‘C a’ with actual type of ‘B’
+    In the pattern synonym: MyC
+    In the export: C(MyC)
diff --git a/testsuite/tests/patsyn/should_fail/import-syntax.hs b/testsuite/tests/patsyn/should_fail/import-syntax.hs
new file mode 100644
index 0000000000..8242c57527
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/import-syntax.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo where
+
+import ImportSyntax (A(.., B))
diff --git a/testsuite/tests/patsyn/should_fail/import-syntax.stderr b/testsuite/tests/patsyn/should_fail/import-syntax.stderr
new file mode 100644
index 0000000000..5ada7e94ae
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/import-syntax.stderr
@@ -0,0 +1,3 @@
+
+import-syntax.hs:4:22: error:
+    Illegal import form, this syntax can only be used to bundle pattern synonyms with types in module exports.
diff --git a/testsuite/tests/patsyn/should_fail/poly-export-fail2.hs b/testsuite/tests/patsyn/should_fail/poly-export-fail2.hs
new file mode 100644
index 0000000000..1345ae5d9e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/poly-export-fail2.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Foo (A(P)) where
+
+data A = A
+
+data B = B
+
+pattern P :: () => (f ~ B) => f
+pattern P = B
diff --git a/testsuite/tests/patsyn/should_fail/poly-export-fail2.stderr b/testsuite/tests/patsyn/should_fail/poly-export-fail2.stderr
new file mode 100644
index 0000000000..686469556e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/poly-export-fail2.stderr
@@ -0,0 +1,7 @@
+
+poly-export-fail2.hs:2:13: error:
+    Couldn't match expected type ‘A’ with actual type ‘B’
+    When checking that: forall f. (f ~ B) => f
+      is more polymorphic than: A
+    In the pattern synonym: P
+    In the export: A(P)