Add TH support for pattern synonyms (fixes #8761)

This commit adds Template Haskell support for pattern synonyms as
requested by trac ticket #8761.

Test Plan: ./validate

Reviewers: thomie, jstolarek, osa1, RyanGlScott, mpickering, austin,
goldfire, bgamari

Reviewed By: goldfire, bgamari

Subscribers: rdragon

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

GHC Trac Issues: #8761

1 files changed, 111 insertions, 0 deletions

diff --git a/testsuite/tests/th/T8761.hs b/testsuite/tests/th/T8761.hs
new file mode 100644
index 0000000000..4578822904
--- /dev/null
+++ b/testsuite/tests/th/T8761.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE TemplateHaskell, RankNTypes, GADTs, PatternSynonyms #-}
+
+module T8761 where
+
+{- Testsuite for pattern synonyms as implemented by ticket #8761 -}
+
+import Control.Monad
+import Language.Haskell.TH
+
+data Ex         where MkEx       :: forall a. a -> Ex
+data ExProv     where MkExProv   :: forall a. (Show a) => a -> ExProv
+data UnivProv a where MkUnivProv :: forall a. (Show a) => a -> UnivProv a
+
+{- Test manual construction and pretty printing of pattern synonyms -}
+do
+  [qx1,qy1,qz1] <- mapM (\i -> newName $ "x" ++ show i) [1,2,3]
+  let nm1       = mkName "Q1"
+      prefixPat = patSynD nm1 (prefixPatSyn [qx1,qy1,qz1]) unidir
+        (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP])
+
+  [qx2,qy2] <- mapM (\i -> newName $ "x" ++ show i) [1,2]
+  let nm2      = mkName "Q2"
+      infixPat = patSynD nm2 (infixPatSyn qx2 qy2) implBidir
+        (tupP [tupP [varP qx2, varP qy2]])
+
+  let nm3           = mkName "Q3"
+      [qx3,qy3,qz3] = map mkName ["qx3", "qy3", "qz3"]
+      patP          = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]]
+      patE          = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]]
+      cls           = clause [varP qx3, varP qy3, varP qz3] (normalB patE) []
+      recordPat     = patSynD nm3 (recordPatSyn [qx3,qy3,qz3])
+                        (explBidir [cls]) patP
+
+  pats <- sequence [prefixPat, infixPat, recordPat]
+  -- pretty print the pattern synonyms:
+  mapM_ (runIO . putStrLn . pprint) pats
+  -- splice in the pattern synonyms
+  return pats
+
+{- Test prefix pattern synonyms -}
+[d|
+ pattern P1 x y z <- ((x,y), [z], _, _)   -- unidirectional pattern
+ pattern P2 x y z =  ((x,y), [z])         -- implicit bidirectional pattern
+ pattern P3 x y z <- ((x,y), [z]) where   -- explicit bidirectional pattern
+   P3 x y z = ((x,y), [z]) |]
+
+{- Test infix pattern synonyms -}
+[d|
+ pattern x :*: y <- ((x,_), [y])
+ pattern x :+: y =  (x,y)
+ pattern x :~: y <- (x,y) where
+   x :~: y = (x,y) |]
+
+{- Test record pattern synonyms -}
+[d|
+ pattern R1 {x1, y1} <- ((x1,_), [y1])
+ getX1 = x1 ((1, 2), [3]) -- should yield 1
+ getY1 = y1 ((1, 2), [3]) -- should yield 3
+ pattern R2 {x2, y2} =  (x2, [y2])
+ pattern R3 {x3, y3} <- (x3, [y3]) where
+   R3 x y = (x, [y]) |]
+
+--x1 = "no, no, no"
+--y1 = "no, no, no"
+
+getX1' = x1 ((1, 2), [3]) -- should yield 1
+getY1' = y1 ((1, 2), [3]) -- should yield 3
+
+{- Test splicing unidirectional pattern synonyms with different types -}
+[d|
+ pattern P :: Bool
+ pattern P <- True
+
+ pattern Pe :: () => forall a. a -> Ex
+ pattern Pe x <- MkEx x
+
+ pattern Pu :: forall a. a -> a
+ pattern Pu x <-  x
+
+ pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex)
+ pattern Pue x y <- (x, MkEx y)
+
+ pattern Pur :: forall a. (Num a, Eq a) => a -> [a]
+ pattern Pur x <- [x, 1]
+
+ pattern Purp :: forall a b. (Num a, Eq a) =>
+                 Show b => a -> b -> ([a], UnivProv b)
+ pattern Purp x y <- ([x, 1], MkUnivProv y)
+
+ pattern Pure :: forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex)
+ pattern Pure x y <- ([x, 1], MkEx y)
+
+ pattern Purep :: forall a. (Num a, Eq a) =>
+                 forall b. Show b => a -> b -> ([a], ExProv)
+ pattern Purep x y <- ([x, 1], MkExProv y)
+
+ pattern Pep :: () => forall a. Show a => a -> ExProv
+ pattern Pep x <- MkExProv x
+
+ pattern Pup :: forall a. () => Show a => a -> UnivProv a
+ pattern Pup x <- MkUnivProv x
+
+ pattern Puep :: forall a. () => forall b. (Show b) => a -> b -> (ExProv, a)
+ pattern Puep x y <- (MkExProv y, x) |]
+
+{- Test reification of different pattern synonyms and their types -}
+do
+  infos <- mapM reify [ 'P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp
+                      , 'Pure, 'Purep, 'Pep, 'Pup, 'Puep ]
+  mapM_ (runIO . putStrLn . pprint) infos
+  [d| theAnswerIs = 42 |]