Implement pattern synonyms

This patch implements Pattern Synonyms (enabled by -XPatternSynonyms),
allowing y ou to assign names to a pattern and abstract over it.

The rundown is this:

  * Named patterns are introduced by the new 'pattern' keyword, and can
    be either *unidirectional* or *bidirectional*. A unidirectional
    pattern is, in the simplest sense, simply an 'alias' for a pattern,
    where the LHS may mention variables to occur in the RHS. A
    bidirectional pattern synonym occurs when a pattern may also be used
    in expression context.

  * Unidirectional patterns are declared like thus:

        pattern P x <- x:_

    The synonym 'P' may only occur in a pattern context:

        foo :: [Int] -> Maybe Int
        foo (P x) = Just x
        foo _     = Nothing

  * Bidirectional patterns are declared like thus:

        pattern P x y = [x, y]

    Here, P may not only occur as a pattern, but also as an expression
    when given values for 'x' and 'y', i.e.

        bar :: Int -> [Int]
        bar x = P x 10

  * Patterns can't yet have their own type signatures; signatures are inferred.

  * Pattern synonyms may not be recursive, c.f. type synonyms.

  * Pattern synonyms are also exported/imported using the 'pattern'
    keyword in an import/export decl, i.e.

        module Foo (pattern Bar) where ...

    Note that pattern synonyms share the namespace of constructors, so
    this disambiguation is required as a there may also be a 'Bar'
    type in scope as well as the 'Bar' pattern.

  * The semantics of a pattern synonym differ slightly from a typical
    pattern: when using a synonym, the pattern itself is matched,
    followed by all the arguments. This means that the strictness
    differs slightly:

        pattern P x y <- [x, y]

        f (P True True) = True
        f _             = False

        g [True, True] = True
        g _            = False

    In the example, while `g (False:undefined)` evaluates to False,
    `f (False:undefined)` results in undefined as both `x` and `y`
    arguments are matched to `True`.

For more information, see the wiki:

    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms
    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms/Implementation

Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

30 files changed, 244 insertions, 6 deletions

diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index e816f8aa46..40ddb4b66b 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -33,7 +33,8 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "JavaScriptFFI"]
+                             "JavaScriptFFI",
+                             "PatternSynonyms"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs
index 0332b05a51..98e8bd0219 100644
--- a/testsuite/tests/ghc-api/T6145.hs
+++ b/testsuite/tests/ghc-api/T6145.hs
@@ -27,17 +27,17 @@ main = do
                         l <- loadModule d
                         let ts=typecheckedSource l
 --                        liftIO (putStr (showSDocDebug (ppr ts)))
-                        let fs=filterBag getDataCon ts
+                        let fs=filterBag (isDataCon . snd) ts
                         return $ not $ isEmptyBag fs
         removeFile "Test.hs"
         print ok
     where 
-      getDataCon (L _ (AbsBinds { abs_binds = bs }))
-        = not (isEmptyBag (filterBag getDataCon bs))
-      getDataCon (L l (f@FunBind {}))
+      isDataCon (L _ (AbsBinds { abs_binds = bs }))
+        = not (isEmptyBag (filterBag (isDataCon . snd) bs))
+      isDataCon (L l (f@FunBind {}))
         | (MG (m:_) _ _) <- fun_matches f,
           (L _ (c@ConPatOut{}):_)<-hsLMatchPats m,
           (L l _)<-pat_con c
         = isGoodSrcSpan l       -- Check that the source location is a good one
-      getDataCon _ 
+      isDataCon _
         = False
diff --git a/testsuite/tests/patsyn/Makefile b/testsuite/tests/patsyn/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/patsyn/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/patsyn/should_compile/.gitignore b/testsuite/tests/patsyn/should_compile/.gitignore
new file mode 100644
index 0000000000..492f1e78dd
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/.gitignore
@@ -0,0 +1,9 @@
+.hpc.bidir
+.hpc.ex
+.hpc.ex-num
+.hpc.ex-prov
+.hpc.ex-view
+.hpc.incomplete
+.hpc.num
+.hpc.overlap
+.hpc.univ
diff --git a/testsuite/tests/patsyn/should_compile/Makefile b/testsuite/tests/patsyn/should_compile/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
new file mode 100644
index 0000000000..84b231cf61
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -0,0 +1,9 @@
+test('bidir', normal, compile, [''])
+test('overlap', normal, compile, [''])
+test('univ', normal, compile, [''])
+test('ex', normal, compile, [''])
+test('ex-prov', normal, compile, [''])
+test('ex-view', normal, compile, [''])
+test('ex-num', normal, compile, [''])
+test('num', normal, compile, [''])
+test('incomplete', normal, compile, [''])
diff --git a/testsuite/tests/patsyn/should_compile/bidir.hs b/testsuite/tests/patsyn/should_compile/bidir.hs
new file mode 100644
index 0000000000..16f435c2c2
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/bidir.hs
@@ -0,0 +1,6 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern Single x = [x]
diff --git a/testsuite/tests/patsyn/should_compile/ex-num.hs b/testsuite/tests/patsyn/should_compile/ex-num.hs
new file mode 100644
index 0000000000..ff0bf2c97d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ex-num.hs
@@ -0,0 +1,9 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms, GADTs #-}
+module ShouldCompile where
+
+data T a where
+	MkT :: (Eq b) => a -> b -> T a
+
+pattern P x <- MkT 42 x
diff --git a/testsuite/tests/patsyn/should_compile/ex-prov.hs b/testsuite/tests/patsyn/should_compile/ex-prov.hs
new file mode 100644
index 0000000000..9225cf2e1c
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ex-prov.hs
@@ -0,0 +1,12 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms, GADTs #-}
+module ShouldCompile where
+
+data T a where
+	MkT :: (Eq b) => a -> b -> T a
+
+pattern P x y <- MkT x y
+
+f :: T Bool -> Bool
+f (P x y) = x && y == y
diff --git a/testsuite/tests/patsyn/should_compile/ex-view.hs b/testsuite/tests/patsyn/should_compile/ex-view.hs
new file mode 100644
index 0000000000..e317274993
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ex-view.hs
@@ -0,0 +1,12 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}
+module ShouldCompile where
+
+data T a where
+	MkT :: (Eq b) => a -> b -> T a
+
+f :: (Show a) => a -> Bool
+f = undefined
+
+pattern P x <- MkT (f -> True) x
diff --git a/testsuite/tests/patsyn/should_compile/ex.hs b/testsuite/tests/patsyn/should_compile/ex.hs
new file mode 100644
index 0000000000..717fe427f5
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/ex.hs
@@ -0,0 +1,13 @@
+-- Pattern synonyms
+-- Existentially-quantified type variables
+
+{-# LANGUAGE GADTs, PatternSynonyms #-}
+module ShouldCompile where
+
+data T where
+    MkT :: b -> (b -> Bool) -> T
+
+pattern P x f <- MkT x f
+
+test :: T -> Bool
+test (P x f) = f x
diff --git a/testsuite/tests/patsyn/should_compile/incomplete.hs b/testsuite/tests/patsyn/should_compile/incomplete.hs
new file mode 100644
index 0000000000..6f43c7c786
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/incomplete.hs
@@ -0,0 +1,11 @@
+-- Pattern synonyms
+-- Generated code doesn't emit overlapping pattern warnings
+
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern P <- Just True
+
+test1 P = 2
+test1 Nothing = 3
+test1 (Just _) = 4
diff --git a/testsuite/tests/patsyn/should_compile/num.hs b/testsuite/tests/patsyn/should_compile/num.hs
new file mode 100644
index 0000000000..a75ebddd6d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/num.hs
@@ -0,0 +1,6 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern P = 42
diff --git a/testsuite/tests/patsyn/should_compile/overlap.hs b/testsuite/tests/patsyn/should_compile/overlap.hs
new file mode 100644
index 0000000000..c3c9387a2f
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/overlap.hs
@@ -0,0 +1,9 @@
+-- Pattern synonyms
+-- Generated code doesn't emit overlapping pattern warnings
+
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern P = ()
+
+test P = ()
diff --git a/testsuite/tests/patsyn/should_compile/univ.hs b/testsuite/tests/patsyn/should_compile/univ.hs
new file mode 100644
index 0000000000..ea7898e8fe
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/univ.hs
@@ -0,0 +1,11 @@
+-- Pattern synonyms
+-- Universially-quantified type variables
+
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern Single x <- [x]
+
+singleTuple :: [a] -> [b] -> Maybe (a, b)
+singleTuple (Single x) (Single y) = Just (x, y)
+singleTuple _          _          = Nothing
diff --git a/testsuite/tests/patsyn/should_fail/Makefile b/testsuite/tests/patsyn/should_fail/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
new file mode 100644
index 0000000000..e1708d29e0
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -0,0 +1,3 @@
+
+test('mono', normal, compile_fail, [''])
+test('unidir', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/mono.hs b/testsuite/tests/patsyn/should_fail/mono.hs
new file mode 100644
index 0000000000..ef83668934
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/mono.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-}
+module ShouldFail where
+
+pattern Single x = [(x :: Int)]
+
+f :: [Bool] -> Bool
+f (Single x) = x
diff --git a/testsuite/tests/patsyn/should_fail/mono.stderr b/testsuite/tests/patsyn/should_fail/mono.stderr
new file mode 100644
index 0000000000..db54f0b11a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/mono.stderr
@@ -0,0 +1,12 @@
+
+mono.hs:7:4:
+    Couldn't match type ‛Int’ with ‛Bool’
+    Expected type: [Bool]
+      Actual type: [Int]
+    In the pattern: Single x
+    In an equation for ‛f’: f (Single x) = x
+
+mono.hs:7:16:
+    Couldn't match expected type ‛Bool’ with actual type ‛Int’
+    In the expression: x
+    In an equation for ‛f’: f (Single x) = x
diff --git a/testsuite/tests/patsyn/should_fail/unidir.hs b/testsuite/tests/patsyn/should_fail/unidir.hs
new file mode 100644
index 0000000000..020fc12821
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unidir.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldFail where
+
+pattern Head x = x:_
diff --git a/testsuite/tests/patsyn/should_fail/unidir.stderr b/testsuite/tests/patsyn/should_fail/unidir.stderr
new file mode 100644
index 0000000000..ea019bc8e1
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unidir.stderr
@@ -0,0 +1,4 @@
+
+unidir.hs:1:1:
+    Right-hand side of bidirectional pattern synonym cannot be used as an expression
+      x : _
diff --git a/testsuite/tests/patsyn/should_run/.gitignore b/testsuite/tests/patsyn/should_run/.gitignore
new file mode 100644
index 0000000000..7380291005
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/.gitignore
@@ -0,0 +1,7 @@
+eval
+ex-prov
+match
+
+.hpc.eval
+.hpc.ex-prov
+.hpc.match
diff --git a/testsuite/tests/patsyn/should_run/Makefile b/testsuite/tests/patsyn/should_run/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
new file mode 100644
index 0000000000..f5936c66c2
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -0,0 +1,3 @@
+test('eval', normal, compile_and_run, [''])
+test('match', normal, compile_and_run, [''])
+test('ex-prov-run', normal, compile_and_run, [''])
diff --git a/testsuite/tests/patsyn/should_run/eval.hs b/testsuite/tests/patsyn/should_run/eval.hs
new file mode 100644
index 0000000000..a36dc0b0fe
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/eval.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+pattern P x y <- [x, y]
+
+f (P True True) = True
+f _             = False
+
+g [True, True] = True
+g _            = False
+
+
+main = do
+    mapM_ (print . f) tests
+    putStrLn ""
+    mapM_ (print . g) tests
+  where
+    tests = [ [True, True]
+            , [True, False]
+            , [True, True, True]
+            -- , False:undefined
+            ]
diff --git a/testsuite/tests/patsyn/should_run/eval.stdout b/testsuite/tests/patsyn/should_run/eval.stdout
new file mode 100644
index 0000000000..302d62b2cf
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/eval.stdout
@@ -0,0 +1,7 @@
+True
+False
+False
+
+True
+False
+False
diff --git a/testsuite/tests/patsyn/should_run/ex-prov-run.hs b/testsuite/tests/patsyn/should_run/ex-prov-run.hs
new file mode 100644
index 0000000000..846ca90c27
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/ex-prov-run.hs
@@ -0,0 +1,21 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms, GADTs #-}
+module Main where
+
+data T a where
+	MkT :: (Eq b) => a -> b -> T a
+
+pattern P x y <- MkT x y
+
+f :: T Bool -> Bool
+f (P x y) = x && y == y
+
+data Crazy = Crazy
+
+instance Eq Crazy where
+    _ == _ = False
+
+main = do
+    print (f $ MkT True True)
+    print (f $ MkT True Crazy)
diff --git a/testsuite/tests/patsyn/should_run/ex-prov-run.stdout b/testsuite/tests/patsyn/should_run/ex-prov-run.stdout
new file mode 100644
index 0000000000..1cc8b5e10d
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/ex-prov-run.stdout
@@ -0,0 +1,2 @@
+True
+False
diff --git a/testsuite/tests/patsyn/should_run/match.hs b/testsuite/tests/patsyn/should_run/match.hs
new file mode 100644
index 0000000000..830c99f270
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match.hs
@@ -0,0 +1,21 @@
+-- Pattern synonyms
+
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+pattern Single x y = [(x,y)]
+
+foo []                   = 0
+foo [(True, True)]       = 1
+foo (Single True True)   = 2
+foo (Single False False) = 3
+foo _                    = 4
+
+main = mapM_ (print . foo) tests
+  where
+    tests = [ [(True, True)]
+            , []
+            , [(True, False)]
+            , [(False, False)]
+            , repeat (True, True)
+            ]
diff --git a/testsuite/tests/patsyn/should_run/match.stdout b/testsuite/tests/patsyn/should_run/match.stdout
new file mode 100644
index 0000000000..2d90204568
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match.stdout
@@ -0,0 +1,5 @@
+1
+0
+4
+3
+4