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

6 files changed, 186 insertions, 26 deletions

diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index ab9b35525a..0bdc756870 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -59,6 +59,8 @@ instance Binary TH.Clause
 instance Binary TH.InjectivityAnn
 instance Binary TH.FamilyResultSig
 instance Binary TH.TypeFamilyHead
+instance Binary TH.PatSynDir
+instance Binary TH.PatSynArgs
 
 -- We need Binary TypeRep for serializing annotations
 
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 3bca8eaeef..5bd610cd76 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -73,20 +73,22 @@ module Language.Haskell.TH(
         Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
         FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..),
         Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
+        PatSynDir(..), PatSynArgs(..),
     -- ** Expressions
         Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
     -- ** Patterns
         Pat(..), FieldExp, FieldPat,
     -- ** Types
         Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),
-        FamilyResultSig(..), Syntax.InjectivityAnn(..),
+        FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType,
 
     -- * Library functions
     -- ** Abbreviations
         InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ,
         ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ,
         SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ,
-        VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ,
+        VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ,
+        PatSynArgsQ,
 
     -- ** Constructors lifted to 'Q'
     -- *** Literals
@@ -160,7 +162,11 @@ module Language.Haskell.TH(
     pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
     pragLineD,
 
-        -- * Pretty-printer
+    -- **** Pattern Synonyms
+    patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
+    infixPatSyn, recordPatSyn,
+
+    -- * Pretty-printer
     Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
 
    ) where
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
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 2a56620684..ca74db7e45 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -19,10 +19,10 @@ nestDepth = 4
 
 type Precedence = Int
 appPrec, unopPrec, opPrec, noPrec :: Precedence
-appPrec = 3    -- Argument of a function application
-opPrec  = 2    -- Argument of an infix operator
-unopPrec = 1   -- Argument of an unresolved infix operator
-noPrec  = 0    -- Others
+appPrec  = 3    -- Argument of a function application
+opPrec   = 2    -- Argument of an infix operator
+unopPrec = 1    -- Argument of an unresolved infix operator
+noPrec   = 0    -- Others
 
 parensIf :: Bool -> Doc -> Doc
 parensIf True d = parens d
@@ -59,6 +59,7 @@ instance Ppr Info where
       = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
     ppr (DataConI v ty tc)
       = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
+    ppr (PatSynI nm ty) = pprPatSynSig nm ty
     ppr (TyVarI v ty)
       = text "Type variable" <+> ppr v <+> equals <+> ppr ty
     ppr (VarI v ty mb_d)
@@ -75,6 +76,24 @@ pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
           ppr_fix InfixL = text "infixl"
           ppr_fix InfixN = text "infix"
 
+-- | Pretty prints a pattern synonym type signature
+pprPatSynSig :: Name -> PatSynType -> Doc
+pprPatSynSig nm ty
+  = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty
+
+-- | Pretty prints a pattern synonym's type; follows the usual
+-- conventions to print a pattern synonym type compactly, yet
+-- unambiguously. See the note on 'PatSynType' and the section on
+-- pattern synonyms in the GHC users guide for more information.
+pprPatSynType :: PatSynType -> Doc
+pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
+  | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')
+  | null uniTys, null reqs  = noreqs <+> ppr ty'
+  | null reqs               = forall uniTys <+> noreqs <+> ppr ty'
+  | otherwise               = ppr ty
+  where noreqs     = text "() =>"
+        forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."
+pprPatSynType ty            = ppr ty
 
 ------------------------------
 instance Ppr Module where
@@ -330,15 +349,22 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
   where
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
-
 ppr_dec _ (RoleAnnotD name roles)
   = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
-
 ppr_dec _ (StandaloneDerivD cxt ty)
   = hsep [ text "deriving instance", pprCxt cxt, ppr ty ]
-
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
+ppr_dec _ (PatSynD name args dir pat)
+  = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
+  where
+    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
+                | otherwise                 = ppr name <+> ppr args
+    pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
+                                           nestDepth (ppr name <+> ppr cls)
+                | otherwise            = ppr pat
+ppr_dec _ (PatSynSigD name ty)
+  = pprPatSynSig name ty
 
 
 ppr_overlap :: Overlap -> Doc
@@ -533,13 +559,28 @@ instance Ppr Con where
     ppr (RecGadtC c vsts ty)
         = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
 
+instance Ppr PatSynDir where
+  ppr Unidir        = text "<-"
+  ppr ImplBidir     = text "="
+  ppr (ExplBidir _) = text "<-"
+    -- the ExplBidir's clauses are pretty printed together with the
+    -- entire pattern synonym; so only print the direction here.
+
+instance Ppr PatSynArgs where
+  ppr (PrefixPatSyn args) = sep $ map ppr args
+  ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
+  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))
+
 commaSepApplied :: [Name] -> Doc
 commaSepApplied = commaSepWith (pprName' Applied)
 
 pprForall :: [TyVarBndr] -> Cxt -> Doc
-pprForall ns ctxt
-    = text "forall" <+> hsep (map ppr ns)
-  <+> char '.' <+> pprCxt ctxt
+pprForall tvs cxt
+  -- even in the case without any tvs, there could be a non-empty
+  -- context cxt (e.g., in the case of pattern synonyms, where there
+  -- are multiple forall binders and contexts).
+  | [] <- tvs = pprCxt cxt
+  | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt
 
 pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
 pprRecFields vsts ty
@@ -639,9 +680,7 @@ pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
 pprUInfixT t               = ppr t
 
 instance Ppr Type where
-    ppr (ForallT tvars ctxt ty)
-      = text "forall" <+> hsep (map ppr tvars) <+> text "."
-                      <+> sep [pprCxt ctxt, ppr ty]
+    ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
     ppr ty = pprTyApp (split ty)
        -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
        -- See Note [Pretty-printing kind signatures]
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
index 378888d77f..32980ab6cc 100644
--- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
@@ -137,7 +137,7 @@ instance Show Name where
   show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)
   show (Name occ NameS)        = occString occ
   show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
-      
+
 data Name = Name OccName NameFlavour
 
 data NameFlavour
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 8022f94b87..fc9c80d140 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1231,6 +1231,11 @@ data Info
        Type
        ParentName
 
+  -- | A pattern synonym.
+  | PatSynI
+       Name
+       PatSynType
+
   {- |
   A \"value\" variable (as opposed to a type variable, see 'TyVarI').
 
@@ -1545,9 +1550,21 @@ data Dec
   | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
        -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
 
-  | RoleAnnotD Name [Role]        -- ^ @{ type role T nominal representational }@
-  | StandaloneDerivD Cxt Type     -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
-  | DefaultSigD Name Type         -- ^ @{ default size :: Data a => a -> Int }@
+  | RoleAnnotD Name [Role]     -- ^ @{ type role T nominal representational }@
+  | StandaloneDerivD Cxt Type  -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
+  | DefaultSigD Name Type      -- ^ @{ default size :: Data a => a -> Int }@
+
+  -- | Pattern Synonyms
+  | PatSynD Name PatSynArgs PatSynDir Pat
+      -- ^ @{ pattern P v1 v2 .. vn <- p }@  unidirectional           or
+      --   @{ pattern P v1 v2 .. vn = p  }@  implicit bidirectional   or
+      --   @{ pattern P v1 v2 .. vn <- p
+      --        where P v1 v2 .. vn = e  }@  explicit bidirectional
+      --
+      -- also, besides prefix pattern synonyms, both infix and record
+      -- pattern synonyms are supported. See 'PatSynArgs' for details
+
+  | PatSynSigD Name PatSynType  -- ^ A pattern synonym's type signature.
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
 -- | Varieties of allowed instance overlap.
@@ -1559,11 +1576,58 @@ data Overlap = Overlappable   -- ^ May be overlapped by more specific instances
                               -- available.
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
--- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
--- By analogy with with "head" for type classes and type class instances as
+-- | A Pattern synonym's type. Note that a pattern synonym's *fully*
+-- specified type has a peculiar shape coming with two forall
+-- quantifiers and two constraint contexts. For example, consider the
+-- pattern synonym
+--
+--   pattern P x1 x2 ... xn = <some-pattern>
+--
+-- P's complete type is of the following form
+--
+--   forall universals. required constraints
+--     => forall existentials. provided constraints
+--     => t1 -> t2 -> ... -> tn -> t
+--
+-- consisting of four parts:
+--
+--   1) the (possibly empty lists of) universally quantified type
+--      variables and required constraints on them.
+--   2) the (possibly empty lists of) existentially quantified
+--      type variables and the provided constraints on them.
+--   3) the types t1, t2, .., tn of x1, x2, .., xn, respectively
+--   4) the type t of <some-pattern>, mentioning only universals.
+--
+-- Pattern synonym types interact with TH when (a) reifying a pattern
+-- synonym, (b) pretty printing, or (c) specifying a pattern synonym's
+-- type signature explicitly:
+--
+-- (a) Reification always returns a pattern synonym's *fully* specified
+--     type in abstract syntax.
+--
+-- (b) Pretty printing via 'pprPatSynType' abbreviates a pattern
+--     synonym's type unambiguously in concrete syntax: The rule of
+--     thumb is to print initial empty universals and the required
+--     context as `() =>`, if existentials and a provided context
+--     follow. If only universals and their required context, but no
+--     existentials are specified, only the universals and their
+--     required context are printed. If both or none are specified, so
+--     both (or none) are printed.
+--
+-- (c) When specifying a pattern synonym's type explicitly with
+--     'PatSynSigD' either one of the universals, the existentials, or
+--     their contexts may be left empty.
+--
+-- See the GHC users guide for more information on pattern synonyms
+-- and their types: https://downloads.haskell.org/~ghc/latest/docs/html/
+-- users_guide/syntax-extns.html#pattern-synonyms.
+type PatSynType = Type
+
+-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By
+-- analogy with "head" for type classes and type class instances as
 -- defined in /Type classes: an exploration of the design space/, the
--- @TypeFamilyHead@ is defined to be the elements of the declaration between
--- @type family@ and @where@.
+-- @TypeFamilyHead@ is defined to be the elements of the declaration
+-- between @type family@ and @where@.
 data TypeFamilyHead =
   TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn)
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
@@ -1707,6 +1771,20 @@ type StrictType    = BangType
 -- 'VarBangType'.
 type VarStrictType = VarBangType
 
+-- | A pattern synonym's directionality.
+data PatSynDir
+  = Unidir             -- ^ @pattern P x {<-} p@
+  | ImplBidir          -- ^ @pattern P x {=} p@
+  | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@
+  deriving( Show, Eq, Ord, Data, Typeable, Generic )
+
+-- | A pattern synonym's argument type.
+data PatSynArgs
+  = PrefixPatSyn [Name]        -- ^ @pattern P {x y z} = p@
+  | InfixPatSyn Name Name      -- ^ @pattern {x P y} = p@
+  | RecordPatSyn [Name]        -- ^ @pattern P { {x,y,z} } = p@
+  deriving( Show, Eq, Ord, Data, Typeable, Generic )
+
 data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@
           | AppT Type Type                -- ^ @T a b@
           | SigT Type Kind                -- ^ @t :: k@