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, 37 insertions, 2 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 6971970524..d4529e1915 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -46,6 +46,8 @@ type VarStrictTypeQ      = Q VarStrictType
 type FieldExpQ           = Q FieldExp
 type RuleBndrQ           = Q RuleBndr
 type TySynEqnQ           = Q TySynEqn
+type PatSynDirQ          = Q PatSynDir
+type PatSynArgsQ         = Q PatSynArgs
 
 -- must be defined here for DsMeta to find it
 type Role                = TH.Role
@@ -531,6 +533,20 @@ defaultSigD n tyq =
     ty <- tyq
     return $ DefaultSigD n ty
 
+-- | Pattern synonym declaration
+patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
+patSynD name args dir pat = do
+  args'    <- args
+  dir'     <- dir
+  pat'     <- pat
+  return (PatSynD name args' dir' pat')
+
+-- | Pattern synonym type signature
+patSynSigD :: Name -> TypeQ -> DecQ
+patSynSigD nm ty =
+  do ty' <- ty
+     return $ PatSynSigD nm ty'
+
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
   do
@@ -706,8 +722,6 @@ numTyLit n = if n >= 0 then return (NumTyLit n)
 strTyLit :: String -> TyLitQ
 strTyLit s = return (StrTyLit s)
 
-
-
 -------------------------------------------------------------------------------
 -- *   Kind
 
@@ -818,6 +832,27 @@ typeAnnotation = TypeAnnotation
 moduleAnnotation :: AnnTarget
 moduleAnnotation = ModuleAnnotation
 
+-------------------------------------------------------------------------------
+-- * Pattern Synonyms (sub constructs)
+
+unidir, implBidir :: PatSynDirQ
+unidir    = return Unidir
+implBidir = return ImplBidir
+
+explBidir :: [ClauseQ] -> PatSynDirQ
+explBidir cls = do
+  cls' <- sequence cls
+  return (ExplBidir cls')
+
+prefixPatSyn :: [Name] -> PatSynArgsQ
+prefixPatSyn args = return $ PrefixPatSyn args
+
+recordPatSyn :: [Name] -> PatSynArgsQ
+recordPatSyn sels = return $ RecordPatSyn sels
+
+infixPatSyn :: Name -> Name -> PatSynArgsQ
+infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
+
 --------------------------------------------------------------
 -- * Useful helper function