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

20 files changed, 833 insertions, 164 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b00717e53a..370e310204 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TypeFamilies #-}
 
 -----------------------------------------------------------------------------
 --
@@ -119,8 +119,9 @@ repTopDs group@(HsGroup { hs_valds   = valds
                         , hs_ruleds  = ruleds
                         , hs_vects   = vects
                         , hs_docs    = docs })
- = do { let { tv_bndrs = hsSigTvBinders valds
-            ; bndrs = tv_bndrs ++ hsGroupBinders group
+ = do { let { bndrs  = hsSigTvBinders valds
+                       ++ hsGroupBinders group
+                       ++ hsPatSynSelectors valds
             ; instds = tyclds >>= group_instds } ;
         ss <- mkGenSyms bndrs ;
 
@@ -197,7 +198,6 @@ hsSigTvBinders binds
              ValBindsIn  _ sigs -> sigs
              ValBindsOut _ sigs -> sigs
 
-
 {- Notes
 
 Note [Scoped type variables in bindings]
@@ -700,7 +700,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
+rep_sig (L loc (PatSynSig nm ty))     = (:[]) <$> rep_patsyn_ty_sig loc ty nm
 rep_sig (L loc (ClassOpSig is_deflt nms ty))
   | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms
   | otherwise                         = mapM (rep_ty_sig sigDName loc ty) nms
@@ -708,7 +708,7 @@ rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
 rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm tys ispec))
-   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
 rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
@@ -720,6 +720,16 @@ rep_ty_sig mk_sig loc sig_ty nm
        ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
 
+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name
+                  -> DsM (SrcSpan, Core TH.DecQ)
+-- represents a pattern synonym type signature; see NOTE [Pattern
+-- synonym signatures and Template Haskell]
+rep_patsyn_ty_sig loc sig_ty nm
+  = do { nm1 <- lookupLOcc nm
+       ; ty1 <- repHsPatSynSigType sig_ty
+       ; sig <- repProto patSynSigDName nm1 ty1
+       ; return (loc, sig) }
+
 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
               -> DsM (SrcSpan, Core TH.DecQ)
     -- We must special-case the top-level explicit for-all of a TypeSig
@@ -889,17 +899,32 @@ repHsSigType (HsIB { hsib_vars = vars
          then return th_ty
          else repTForall th_tvs th_ctxt th_ty }
 
+repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
+repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
+                         , hsib_body = body })
+  = addTyVarBinds (newTvs (impls ++ univs)) $ \th_univs ->
+      addTyVarBinds (newTvs exis) $ \th_exis ->
+    do { th_reqs  <- repLContext reqs
+       ; th_provs <- repLContext provs
+       ; th_ty    <- repLTy ty
+       ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
+  where
+    impls = map (noLoc . UserTyVar . noLoc) implicit_tvs
+    newTvs tvs = HsQTvs
+      { hsq_implicit  = []
+      , hsq_explicit  = tvs
+      , hsq_dependent = emptyNameSet }
+    (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
+
 repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
 repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
   = repHsSigType (ib_ty { hsib_body = hswc_body sig1 })
 
 -- yield the representation of a list of types
---
 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 repLTys tys = mapM repLTy tys
 
 -- represent a type
---
 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 repLTy (L _ ty) = repTy ty
 
@@ -1073,11 +1098,11 @@ repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 repE (HsVar (L _ x))            =
   do { mb_val <- dsLookupMetaEnv x
      ; case mb_val of
-        Nothing          -> do { str <- globalVar x
-                               ; repVarOrCon x str }
+        Nothing            -> do { str <- globalVar x
+                                 ; repVarOrCon x str }
         Just (DsBound y)   -> repVarOrCon x (coreVar y)
         Just (DsSplice e)  -> do { e' <- dsExpr e
-                               ; return (MkC e') } }
+                                 ; return (MkC e') } }
 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
 
@@ -1415,7 +1440,87 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
 rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
-rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
+rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
+                                 , psb_fvs  = _fvs
+                                 , psb_args = args
+                                 , psb_def  = pat
+                                 , psb_dir  = dir })))
+  = do { syn'      <- lookupLBinder syn
+       ; dir'      <- repPatSynDir dir
+       ; ss        <- mkGenArgSyms args
+       ; patSynD'  <- addBinds ss (
+         do { args'  <- repPatSynArgs args
+            ; pat'   <- repLP pat
+            ; repPatSynD syn' args' dir' pat' })
+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'
+       ; return (loc, patSynD'') }
+  where
+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
+    -- for Record Pattern Synonyms we want to conflate the selector
+    -- and the pattern-only names in order to provide a nicer TH
+    -- API. Whereas inside GHC, record pattern synonym selectors and
+    -- their pattern-only bound right hand sides have different names,
+    -- we want to treat them the same in TH. This is the reason why we
+    -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
+    mkGenArgSyms (PrefixPatSyn args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecordPatSyn fields)
+      = do { let pats = map (unLoc . recordPatSynPatVar) fields
+                 sels = map (unLoc . recordPatSynSelectorId) fields
+           ; ss <- mkGenSyms sels
+           ; return $ replaceNames (zip sels pats) ss }
+
+    replaceNames selsPats genSyms
+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
+                    , sel == sel' ]
+
+    wrapGenArgSyms :: HsPatSynDetails (Located Name)
+                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
+    wrapGenArgSyms (RecordPatSyn _) _  dec = return dec
+    wrapGenArgSyms _                ss dec = wrapGenSyms ss dec
+
+repPatSynD :: Core TH.Name
+           -> Core TH.PatSynArgsQ
+           -> Core TH.PatSynDirQ
+           -> Core TH.PatQ
+           -> DsM (Core TH.DecQ)
+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
+  = rep2 patSynDName [syn, args, dir, pat]
+
+repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
+repPatSynArgs (PrefixPatSyn args)
+  = do { args' <- repList nameTyConName lookupLOcc args
+       ; repPrefixPatSynArgs args' }
+repPatSynArgs (InfixPatSyn arg1 arg2)
+  = do { arg1' <- lookupLOcc arg1
+       ; arg2' <- lookupLOcc arg2
+       ; repInfixPatSynArgs arg1' arg2' }
+repPatSynArgs (RecordPatSyn fields)
+  = do { sels' <- repList nameTyConName lookupLOcc sels
+       ; repRecordPatSynArgs sels' }
+  where sels = map recordPatSynSelectorId fields
+
+repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
+
+repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
+
+repRecordPatSynArgs :: Core [TH.Name]
+                    -> DsM (Core TH.PatSynArgsQ)
+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
+
+repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ)
+repPatSynDir Unidirectional        = rep2 unidirPatSynName []
+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
+  = do { clauses' <- mapM repClauseTup clauses
+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+
+repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
+
+
 -----------------------------------------------------------------------------
 -- Since everything in a Bind is mutually recursive we need rename all
 -- all the variables simultaneously. For example:
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 9274725fe6..63904ed219 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -350,6 +350,33 @@ cvtDec (TH.DefaultSigD nm typ)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType typ
        ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
+
+cvtDec (TH.PatSynD nm args dir pat)
+  = do { nm'   <- cNameL nm
+       ; args' <- cvtArgs args
+       ; dir'  <- cvtDir dir
+       ; pat'  <- cvtPat pat
+       ; returnJustL $ Hs.ValD $ PatSynBind $
+           PSB nm' placeHolderType args' pat' dir' }
+  where
+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
+    cvtArgs (TH.RecordPatSyn sels)
+      = do { sels' <- mapM vNameL sels
+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
+           ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
+
+    cvtDir Unidir          = return Unidirectional
+    cvtDir ImplBidir       = return ImplicitBidirectional
+    cvtDir (ExplBidir cls) =
+      do { ms <- mapM cvtClause cls
+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+
+cvtDec (TH.PatSynSigD nm ty)
+  = do { nm' <- cNameL nm
+       ; ty' <- cvtPatSynSigTy ty
+       ; returnJustL $ Hs.SigD $ PatSynSig nm' (mkLHsSigType ty') }
+
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)
@@ -725,9 +752,9 @@ cvtl e = wrapL (cvt e)
       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
-                              ; return $ HsApp (mkLHsPar x') y' }
+                                   ; return $ HsApp (mkLHsPar x') y' }
     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
-                              ; return $ HsApp x' y' }
+                                   ; return $ HsApp x' y' }
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
     cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
@@ -1276,6 +1303,27 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
        ; annRHS' <- mapM tNameL annRHS
        ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
 
+cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName)
+-- pattern synonym types are of peculiar shapes, which is why we treat
+-- them separately from regular types; see NOTE [Pattern synonym
+-- signatures and Template Haskell]
+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
+  | null exis, null provs = cvtType (ForallT univs reqs ty)
+  | null univs, null reqs = do { l   <- getL
+                               ; ty' <- cvtType (ForallT exis provs ty)
+                               ; return $ L l (HsQualTy { hst_ctxt = L l []
+                                                        , hst_body = ty' }) }
+  | null reqs             = do { l      <- getL
+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs
+                               ; ty'    <- cvtType (ForallT exis provs ty)
+                               ; let forTy = HsForAllTy { hst_bndrs = univs'
+                                                        , hst_body = L l cxtTy }
+                                     cxtTy = HsQualTy { hst_ctxt = L l []
+                                                      , hst_body = ty' }
+                               ; return $ L l forTy }
+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
+cvtPatSynSigTy ty         = cvtType ty
+
 -----------------------------------------------------------
 cvtFixity :: TH.Fixity -> Hs.Fixity
 cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir)
@@ -1474,3 +1522,59 @@ the way System Names are printed.
 There's a small complication of course; see Note [Looking up Exact
 RdrNames] in RnEnv.
 -}
+
+{-
+Note [Pattern synonym type signatures and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In general, the type signature of a pattern synonym
+
+  pattern P x1 x2 .. xn = <some-pattern>
+
+is of the form
+
+   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+with the following parts:
+
+   1) the (possibly empty lists of) universally quantified type
+      variables `univs` and required constraints `reqs` on them.
+   2) the (possibly empty lists of) existentially quantified type
+      variables `exis` and the provided constraints `provs` on them.
+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
+      x2, .., xn, respectively
+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
+
+Due to the two forall quantifiers and constraint contexts (either of
+which might be empty), pattern synonym type signatures are treated
+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
+`typecheck/TcSplice.hs`:
+
+   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+   (b) When converting pattern synonyms from TH.Dec to HsSyn in
+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an
+       appropriate Haskell pattern synonym type of the form
+
+         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+       where initial empty `univs` type variables or an empty `reqs`
+       constraint context are represented *explicitly* as `() =>`.
+
+   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
+       return its *full* type, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+The key point is to always represent a pattern synonym's *full* type
+in cases (a) and (c) to make it clear which of the two forall
+quantifiers and/or constraint contexts are specified, and which are
+not. See GHC's users guide on pattern synonyms for more information
+about pattern synonym type signatures.
+
+-}
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 04b0ae8c2d..bc78a7d270 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -984,22 +984,17 @@ splitHsAppTys f                   as = (f,as)
 
 --------------------------------
 splitLHsPatSynTy :: LHsType name
-                 -> ( [LHsTyVarBndr name]
-                    , LHsContext name        -- Required
-                    , LHsContext name        -- Provided
-                    , LHsType name)          -- Body
-splitLHsPatSynTy ty
-  | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
-  , L _ (HsQualTy { hst_ctxt = prov,  hst_body = ty3 }) <- ty2
-  = (tvs, req, prov, ty3)
-
-  | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
-  = (tvs, req, noLoc [], ty2)
-
-  | otherwise
-  = (tvs, noLoc [], noLoc [], ty1)
+                 -> ( [LHsTyVarBndr name]    -- universals
+                    , LHsContext name        -- required constraints
+                    , [LHsTyVarBndr name]    -- existentials
+                    , LHsContext name        -- provided constraints
+                    , LHsType name)          -- body type
+splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
   where
-    (tvs, ty1) = splitLHsForAllTy ty
+    (univs, ty1) = splitLHsForAllTy ty
+    (reqs,  ty2) = splitLHsQualTy ty1
+    (exis,  ty3) = splitLHsForAllTy ty2
+    (provs, ty4) = splitLHsQualTy ty3
 
 splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name)
 splitLHsSigmaTy ty
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 35f146b55e..ee34773e1d 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -78,7 +78,7 @@ module HsUtils(
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
 
-  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
+  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
   hsDataDefnBinders,
 
@@ -784,8 +784,9 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
         -- The only time we collect binders from a typechecked
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
-collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
-    if omitPatSyn then acc else ps : acc
+collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
+  | omitPatSyn                  = acc
+  | otherwise                   = ps : acc
 
 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
@@ -935,26 +936,19 @@ hsForeignDeclsBinders foreign_decls
     | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
 
 
-
 -------------------
-hsPatSynBinders :: HsValBinds RdrName
-                -> ([Located RdrName], [Located RdrName])
--- Collect pattern-synonym binders only, not Ids
--- See Note [SrcSpan for binders]
-hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
-hsPatSynBinders _ = panic "hsPatSynBinders"
-
-addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
-                -> ([Located id], [Located id]) -- (selectors, other)
--- See Note [SrcSpan for binders]
-addPatSynBndr bind (sels, pss)
-  | L bind_loc (PatSynBind (PSB { psb_id = L _ n
-                                , psb_args = RecordPatSyn as })) <- bind
-  = (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
-  | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
-  = (sels, L bind_loc n : pss)
-  | otherwise
-  = (sels, pss)
+hsPatSynSelectors :: HsValBinds id -> [id]
+-- Collects record pattern-synonym selectors only; the pattern synonym
+-- names are collected by collectHsValBinders.
+hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
+hsPatSynSelectors (ValBindsOut binds _)
+  = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
+
+addPatSynSelector:: LHsBind id -> [id] -> [id]
+addPatSynSelector bind sels
+  | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
+  = map (unLoc . recordPatSynSelectorId) as ++ sels
+  | otherwise = sels
 
 -------------------
 hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 671fe490c8..e3a58cccdd 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -71,7 +71,7 @@ templateHaskellNames = [
     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
     dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName,
-    roleAnnotDName,
+    roleAnnotDName, patSynDName, patSynSigDName,
     -- Cxt
     cxtName,
 
@@ -87,6 +87,10 @@ templateHaskellNames = [
     bangTypeName,
     -- VarBangType
     varBangTypeName,
+    -- PatSynDir (for pattern synonyms)
+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
+    -- PatSynArgs (for pattern synonyms)
+    prefixPatSynName, infixPatSynName, recordPatSynName,
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
@@ -325,10 +329,10 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
     pragSpecDName,
     pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
-    standaloneDerivDName, defaultSigDName,
-    dataInstDName, newtypeInstDName, tySynInstDName,
-    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
-    infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
+    standaloneDerivDName, defaultSigDName, dataInstDName, newtypeInstDName,
+    tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
+    infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName,
+    patSynSigDName :: Name
 funDName             = libFun (fsLit "funD")              funDIdKey
 valDName             = libFun (fsLit "valD")              valDIdKey
 dataDName            = libFun (fsLit "dataD")             dataDIdKey
@@ -336,8 +340,7 @@ newtypeDName         = libFun (fsLit "newtypeD")          newtypeDIdKey
 tySynDName           = libFun (fsLit "tySynD")            tySynDIdKey
 classDName           = libFun (fsLit "classD")            classDIdKey
 instanceWithOverlapDName
-                     = libFun (fsLit "instanceWithOverlapD")
-                                                      instanceWithOverlapDIdKey
+  = libFun (fsLit "instanceWithOverlapD")              instanceWithOverlapDIdKey
 standaloneDerivDName = libFun (fsLit "standaloneDerivD")  standaloneDerivDIdKey
 sigDName             = libFun (fsLit "sigD")              sigDIdKey
 defaultSigDName      = libFun (fsLit "defaultSigD")       defaultSigDIdKey
@@ -358,6 +361,8 @@ infixLDName          = libFun (fsLit "infixLD")           infixLDIdKey
 infixRDName          = libFun (fsLit "infixRD")           infixRDIdKey
 infixNDName          = libFun (fsLit "infixND")           infixNDIdKey
 roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey
+patSynDName          = libFun (fsLit "patSynD")           patSynDIdKey
+patSynSigDName       = libFun (fsLit "patSynSigD")        patSynSigDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -396,6 +401,18 @@ bangTypeName = libFun (fsLit "bangType") bangTKey
 varBangTypeName :: Name
 varBangTypeName = libFun (fsLit "varBangType") varBangTKey
 
+-- data PatSynDir = ...
+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name
+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey
+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey
+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey
+
+-- data PatSynArgs = ...
+prefixPatSynName, infixPatSynName, recordPatSynName :: Name
+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey
+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
+
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
     listTName, appTName, sigTName, equalityTName, litTName,
@@ -557,7 +574,6 @@ overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey
 overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey
 incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey
 
-
 {- *********************************************************************
 *                                                                      *
                      Class keys
@@ -663,8 +679,6 @@ overlappingDataConKey  = mkPreludeDataConUnique 110
 overlapsDataConKey     = mkPreludeDataConUnique 111
 incoherentDataConKey   = mkPreludeDataConUnique 112
 
-
-
 {- *********************************************************************
 *                                                                      *
                      Id keys
@@ -713,8 +727,9 @@ liftStringIdKey :: Unique
 liftStringIdKey     = mkPreludeMiscIdUnique 230
 
 -- data Pat = ...
-litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
-    asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey,
+  tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey,
+  sigPIdKey, viewPIdKey :: Unique
 litPIdKey         = mkPreludeMiscIdUnique 240
 varPIdKey         = mkPreludeMiscIdUnique 241
 tupPIdKey         = mkPreludeMiscIdUnique 242
@@ -782,99 +797,114 @@ unboundVarEIdKey  = mkPreludeMiscIdUnique 297
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
-fieldExpIdKey       = mkPreludeMiscIdUnique 310
+fieldExpIdKey       = mkPreludeMiscIdUnique 305
 
 -- data Body = ...
 guardedBIdKey, normalBIdKey :: Unique
-guardedBIdKey     = mkPreludeMiscIdUnique 311
-normalBIdKey      = mkPreludeMiscIdUnique 312
+guardedBIdKey     = mkPreludeMiscIdUnique 306
+normalBIdKey      = mkPreludeMiscIdUnique 307
 
 -- data Guard = ...
 normalGEIdKey, patGEIdKey :: Unique
-normalGEIdKey     = mkPreludeMiscIdUnique 313
-patGEIdKey        = mkPreludeMiscIdUnique 314
+normalGEIdKey     = mkPreludeMiscIdUnique 308
+patGEIdKey        = mkPreludeMiscIdUnique 309
 
 -- data Stmt = ...
 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
-bindSIdKey       = mkPreludeMiscIdUnique 320
-letSIdKey        = mkPreludeMiscIdUnique 321
-noBindSIdKey     = mkPreludeMiscIdUnique 322
-parSIdKey        = mkPreludeMiscIdUnique 323
+bindSIdKey       = mkPreludeMiscIdUnique 310
+letSIdKey        = mkPreludeMiscIdUnique 311
+noBindSIdKey     = mkPreludeMiscIdUnique 312
+parSIdKey        = mkPreludeMiscIdUnique 313
 
 -- data Dec = ...
-funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
-    classDIdKey, instanceWithOverlapDIdKey, sigDIdKey, forImpDIdKey,
-    pragInlDIdKey,
-    pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
-    pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey,
-    closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
-    standaloneDerivDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey,
-    roleAnnotDIdKey :: Unique
-funDIdKey              = mkPreludeMiscIdUnique 330
-valDIdKey              = mkPreludeMiscIdUnique 331
-dataDIdKey             = mkPreludeMiscIdUnique 332
-newtypeDIdKey          = mkPreludeMiscIdUnique 333
-tySynDIdKey            = mkPreludeMiscIdUnique 334
-classDIdKey            = mkPreludeMiscIdUnique 335
-instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 336
-sigDIdKey              = mkPreludeMiscIdUnique 337
-forImpDIdKey           = mkPreludeMiscIdUnique 338
-pragInlDIdKey          = mkPreludeMiscIdUnique 339
-pragSpecDIdKey         = mkPreludeMiscIdUnique 340
-pragSpecInlDIdKey      = mkPreludeMiscIdUnique 341
-pragSpecInstDIdKey     = mkPreludeMiscIdUnique 342
-pragRuleDIdKey         = mkPreludeMiscIdUnique 343
-pragAnnDIdKey          = mkPreludeMiscIdUnique 344
-dataFamilyDIdKey       = mkPreludeMiscIdUnique 345
-openTypeFamilyDIdKey   = mkPreludeMiscIdUnique 346
-dataInstDIdKey         = mkPreludeMiscIdUnique 347
-newtypeInstDIdKey      = mkPreludeMiscIdUnique 348
-tySynInstDIdKey        = mkPreludeMiscIdUnique 349
-closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 350
-infixLDIdKey           = mkPreludeMiscIdUnique 352
-infixRDIdKey           = mkPreludeMiscIdUnique 353
-infixNDIdKey           = mkPreludeMiscIdUnique 354
-roleAnnotDIdKey        = mkPreludeMiscIdUnique 355
-standaloneDerivDIdKey  = mkPreludeMiscIdUnique 356
-defaultSigDIdKey       = mkPreludeMiscIdUnique 357
+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, infixLDIdKey,
+    infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
+    patSynSigDIdKey :: Unique
+funDIdKey                 = mkPreludeMiscIdUnique 320
+valDIdKey                 = mkPreludeMiscIdUnique 321
+dataDIdKey                = mkPreludeMiscIdUnique 322
+newtypeDIdKey             = mkPreludeMiscIdUnique 323
+tySynDIdKey               = mkPreludeMiscIdUnique 324
+classDIdKey               = mkPreludeMiscIdUnique 325
+instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326
+instanceDIdKey            = mkPreludeMiscIdUnique 327
+sigDIdKey                 = mkPreludeMiscIdUnique 328
+forImpDIdKey              = mkPreludeMiscIdUnique 329
+pragInlDIdKey             = mkPreludeMiscIdUnique 330
+pragSpecDIdKey            = mkPreludeMiscIdUnique 331
+pragSpecInlDIdKey         = mkPreludeMiscIdUnique 332
+pragSpecInstDIdKey        = mkPreludeMiscIdUnique 333
+pragRuleDIdKey            = mkPreludeMiscIdUnique 334
+pragAnnDIdKey             = mkPreludeMiscIdUnique 335
+dataFamilyDIdKey          = mkPreludeMiscIdUnique 336
+openTypeFamilyDIdKey      = mkPreludeMiscIdUnique 337
+dataInstDIdKey            = mkPreludeMiscIdUnique 338
+newtypeInstDIdKey         = mkPreludeMiscIdUnique 339
+tySynInstDIdKey           = mkPreludeMiscIdUnique 340
+closedTypeFamilyDIdKey    = mkPreludeMiscIdUnique 341
+infixLDIdKey              = mkPreludeMiscIdUnique 342
+infixRDIdKey              = mkPreludeMiscIdUnique 343
+infixNDIdKey              = mkPreludeMiscIdUnique 344
+roleAnnotDIdKey           = mkPreludeMiscIdUnique 345
+standaloneDerivDIdKey     = mkPreludeMiscIdUnique 346
+defaultSigDIdKey          = mkPreludeMiscIdUnique 347
+patSynDIdKey              = mkPreludeMiscIdUnique 348
+patSynSigDIdKey           = mkPreludeMiscIdUnique 349
 
 -- type Cxt = ...
 cxtIdKey :: Unique
-cxtIdKey            = mkPreludeMiscIdUnique 360
+cxtIdKey               = mkPreludeMiscIdUnique 350
 
 -- data SourceUnpackedness = ...
 noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
-noSourceUnpackednessKey = mkPreludeMiscIdUnique 361
-sourceNoUnpackKey       = mkPreludeMiscIdUnique 362
-sourceUnpackKey         = mkPreludeMiscIdUnique 363
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 351
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 352
+sourceUnpackKey         = mkPreludeMiscIdUnique 353
 
 -- data SourceStrictness = ...
 noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
-noSourceStrictnessKey   = mkPreludeMiscIdUnique 364
-sourceLazyKey           = mkPreludeMiscIdUnique 365
-sourceStrictKey         = mkPreludeMiscIdUnique 366
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 354
+sourceLazyKey           = mkPreludeMiscIdUnique 355
+sourceStrictKey         = mkPreludeMiscIdUnique 356
 
 -- data Con = ...
 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
   recGadtCIdKey :: Unique
-normalCIdKey      = mkPreludeMiscIdUnique 370
-recCIdKey         = mkPreludeMiscIdUnique 371
-infixCIdKey       = mkPreludeMiscIdUnique 372
-forallCIdKey      = mkPreludeMiscIdUnique 373
-gadtCIdKey        = mkPreludeMiscIdUnique 374
-recGadtCIdKey     = mkPreludeMiscIdUnique 375
+normalCIdKey      = mkPreludeMiscIdUnique 357
+recCIdKey         = mkPreludeMiscIdUnique 358
+infixCIdKey       = mkPreludeMiscIdUnique 359
+forallCIdKey      = mkPreludeMiscIdUnique 360
+gadtCIdKey        = mkPreludeMiscIdUnique 361
+recGadtCIdKey     = mkPreludeMiscIdUnique 362
 
 -- data Bang = ...
 bangIdKey :: Unique
-bangIdKey         = mkPreludeMiscIdUnique 376
+bangIdKey         = mkPreludeMiscIdUnique 363
 
 -- type BangType = ...
 bangTKey :: Unique
-bangTKey          = mkPreludeMiscIdUnique 377
+bangTKey          = mkPreludeMiscIdUnique 364
 
 -- type VarBangType = ...
 varBangTKey :: Unique
-varBangTKey       = mkPreludeMiscIdUnique 378
+varBangTKey       = mkPreludeMiscIdUnique 365
+
+-- data PatSynDir = ...
+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
+unidirPatSynIdKey    = mkPreludeMiscIdUnique 366
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 367
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 368
+
+-- data PatSynArgs = ...
+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
+prefixPatSynIdKey = mkPreludeMiscIdUnique 369
+infixPatSynIdKey  = mkPreludeMiscIdUnique 370
+recordPatSynIdKey = mkPreludeMiscIdUnique 371
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 5483d0d432..828cb95ad7 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -89,7 +89,7 @@ import LoadIface
 import Class
 import TyCon
 import CoAxiom
-import PatSyn ( patSynName )
+import PatSyn
 import ConLike
 import DataCon
 import TcEvidence( TcEvBinds(..) )
@@ -1272,8 +1272,11 @@ reifyThing (AGlobal (AConLike (RealDataCon dc)))
         ; return (TH.DataConI (reifyName name) ty
                               (reifyName (dataConOrigTyCon dc)))
         }
+
 reifyThing (AGlobal (AConLike (PatSynCon ps)))
-  = noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
+  = do { let name = reifyName ps
+       ; ty <- reifyPatSynType (patSynSig ps)
+       ; return (TH.PatSynI name ty) }
 
 reifyThing (ATcId {tct_id = id})
   = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
@@ -1636,6 +1639,20 @@ reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
 
+reifyPatSynType
+  :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
+-- reifies a pattern synonym's type and returns its *complete* type
+-- signature; see NOTE [Pattern synonym signatures and Template
+-- Haskell]
+reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
+  = do { univTyVars' <- reifyTyVars univTyVars Nothing
+       ; req'        <- reifyCxt req
+       ; exTyVars'   <- reifyTyVars exTyVars Nothing
+       ; prov'       <- reifyCxt prov
+       ; tau'        <- reifyType (mkFunTys argTys resTy)
+       ; return $ TH.ForallT univTyVars' req'
+                $ TH.ForallT exTyVars' prov' tau' }
+
 reifyKind :: Kind -> TcM TH.Kind
 reifyKind  ki
   = do { let (kis, ki') = splitFunTys ki
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@
diff --git a/testsuite/tests/quotes/T8759a.stderr b/testsuite/tests/quotes/T8759a.stderr
deleted file mode 100644
index ff0fd495df..0000000000
--- a/testsuite/tests/quotes/T8759a.stderr
+++ /dev/null
@@ -1,4 +0,0 @@
-
-T8759a.hs:5:7:
-    pattern synonyms not (yet) handled by Template Haskell
-      pattern Q = False
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index c34a207292..87081a5dc6 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -13,7 +13,7 @@ test('T5721', normal, compile, ['-v0'])
 test('T6062', normal, compile, ['-v0'])
 test('T8455', normal, compile, ['-v0'])
 test('T8633', normal, compile_and_run, [''])
-test('T8759a', normal, compile_fail, ['-v0'])
+test('T8759a', normal, compile, ['-v0'])
 test('T9824', normal, compile, ['-v0'])
 test('T10384', normal, compile_fail, [''])
 
diff --git a/testsuite/tests/th/T10019.stdout b/testsuite/tests/th/T10019.stdout
index e079405309..fb87a9bd9a 100644
--- a/testsuite/tests/th/T10019.stdout
+++ b/testsuite/tests/th/T10019.stdout
@@ -1 +1 @@
-"Constructor from Ghci1.Option: Ghci1.Some :: forall (a_0 :: *) . a_0 ->\n                                                                 Ghci1.Option a_0"
+"Constructor from Ghci1.Option: Ghci1.Some :: forall (a_0 :: *) .\n                                             a_0 -> Ghci1.Option a_0"
diff --git a/testsuite/tests/th/T8759.stderr b/testsuite/tests/th/T8759.stderr
index 3b5474b1ae..b980c00293 100644
--- a/testsuite/tests/th/T8759.stderr
+++ b/testsuite/tests/th/T8759.stderr
@@ -1,3 +1,3 @@
 
-T8759.hs:9:4:
-    Can't represent pattern synonyms in Template Haskell: P
+T8759.hs:9:4: warning:
+    PatSynI T8759.P (ForallT [] [] (ForallT [] [] (TupleT 0)))
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 |]
diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr
new file mode 100644
index 0000000000..4b3a90c2a2
--- /dev/null
+++ b/testsuite/tests/th/T8761.stderr
@@ -0,0 +1,158 @@
+pattern Q1 x1_0 x2_1 x3_2 <- ((x1_0, x2_1), [x3_2], _, _)
+pattern x1_0 Q2 x2_1 = ((x1_0, x2_1))
+pattern Q3 {qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where
+                                  Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3])
+T8761.hs:(15,1)-(38,13): Splicing declarations
+    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];
+         mapM_ (runIO . putStrLn . pprint) pats;
+         return pats }
+  ======>
+    pattern Q1 x1 x2 x3 <- ((x1, x2), [x3], _, _)
+    pattern x1 `Q2` x2 = ((x1, x2))
+    pattern Q3{qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where
+                                Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3])
+T8761.hs:(41,1)-(45,29): Splicing declarations
+    [d| pattern P1 x y z <- ((x, y), [z], _, _)
+        pattern P2 x y z = ((x, y), [z])
+        pattern P3 x y z <- ((x, y), [z]) where
+                           P3 x y z = ((x, y), [z]) |]
+  ======>
+    pattern P1 x y z <- ((x, y), [z], _, _)
+    pattern P2 x y z = ((x, y), [z])
+    pattern P3 x y z <- ((x, y), [z]) where
+                       P3 x y z = ((x, y), [z])
+T8761.hs:(48,1)-(52,21): Splicing declarations
+    [d| pattern x :*: y <- ((x, _), [y])
+        pattern x :+: y = (x, y)
+        pattern x :~: y <- (x, y) where
+                          (:~:) x y = (x, y) |]
+  ======>
+    pattern x :*: y <- ((x, _), [y])
+    pattern x :+: y = (x, y)
+    pattern x :~: y <- (x, y) where
+                      (:~:) x y = (x, y)
+T8761.hs:(55,1)-(61,23): Splicing declarations
+    [d| pattern R1{x1, y1} <- ((x1, _), [y1])
+        getX1 = x1 ((1, 2), [3])
+        getY1 = y1 ((1, 2), [3])
+        pattern R2{x2, y2} = (x2, [y2])
+        pattern R3{x3, y3} <- (x3, [y3]) where
+                             R3 x y = (x, [y]) |]
+  ======>
+    pattern R1{x1, y1} <- ((x1, _), [y1])
+    getX1 = x1 ((1, 2), [3])
+    getY1 = y1 ((1, 2), [3])
+    pattern R2{x2, y2} = (x2, [y2])
+    pattern R3{x3, y3} <- (x3, [y3]) where
+                         R3 x y = (x, [y])
+T8761.hs:(70,1)-(104,39): Splicing declarations
+    [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) |]
+  ======>
+    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)
+pattern T8761.P :: GHC.Types.Bool
+pattern T8761.Pe :: () => forall (a0_0 :: *) . a0_0 -> T8761.Ex
+pattern T8761.Pu :: forall (a0_0 :: *) . a0_0 -> a0_0
+pattern T8761.Pue :: forall (a0_0 :: *) . () => forall (b0_1 :: *) .
+                                                a0_0 -> b0_1 -> (a0_0, T8761.Ex)
+pattern T8761.Pur :: forall (a0_0 :: *) . (GHC.Num.Num a0_0,
+                                           GHC.Classes.Eq a0_0) =>
+                     a0_0 -> [a0_0]
+pattern T8761.Purp :: forall (a0_0 :: *) (b0_1 :: *) . (GHC.Num.Num a0_0,
+                                                        GHC.Classes.Eq a0_0) =>
+                      GHC.Show.Show b0_1 => a0_0 -> b0_1 -> ([a0_0], T8761.UnivProv b0_1)
+pattern T8761.Pure :: forall (a0_0 :: *) . (GHC.Num.Num a0_0,
+                                            GHC.Classes.Eq a0_0) =>
+                      forall (b0_1 :: *) . a0_0 -> b0_1 -> ([a0_0], T8761.Ex)
+pattern T8761.Purep :: forall (a0_0 :: *) . (GHC.Num.Num a0_0,
+                                             GHC.Classes.Eq a0_0) =>
+                       forall (b0_1 :: *) . GHC.Show.Show b0_1 =>
+                       a0_0 -> b0_1 -> ([a0_0], T8761.ExProv)
+pattern T8761.Pep :: () => forall (a0_0 :: *) . GHC.Show.Show a0_0 =>
+                           a0_0 -> T8761.ExProv
+pattern T8761.Pup :: forall (a0_0 :: *) . () => GHC.Show.Show a0_0 =>
+                                                a0_0 -> T8761.UnivProv a0_0
+pattern T8761.Puep :: forall (a0_0 :: *) . () => forall (b0_1 :: *) . GHC.Show.Show b0_1 =>
+                                                 a0_0 -> b0_1 -> (T8761.ExProv, a0_0)
+T8761.hs:(107,1)-(111,25): Splicing declarations
+    do { infos <- mapM
+                    reify
+                    ['P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp, 'Pure, 'Purep, 'Pep, 'Pup,
+                     'Puep];
+         mapM_ (runIO . putStrLn . pprint) infos;
+         [d| theAnswerIs = 42 |] }
+  ======>
+    theAnswerIs = 42
diff --git a/testsuite/tests/th/T9064.stderr b/testsuite/tests/th/T9064.stderr
index 24fdc8da83..f118e202ad 100644
--- a/testsuite/tests/th/T9064.stderr
+++ b/testsuite/tests/th/T9064.stderr
@@ -1,6 +1,5 @@
 class T9064.C (a_0 :: *)
     where T9064.foo :: forall (a_0 :: *) . T9064.C a_0 =>
-                                           a_0 -> GHC.Base.String
-          default T9064.foo :: forall . GHC.Show.Show a_0 =>
-                                        a_0 -> GHC.Base.String
+                       a_0 -> GHC.Base.String
+          default T9064.foo :: GHC.Show.Show a_0 => a_0 -> GHC.Base.String
 instance T9064.C T9064.Bar
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index a69f8a7413..be6828fe4d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -322,7 +322,7 @@ test('T8625', normal, ghci_script, ['T8625.script'])
 test('TH_StaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, [''])
 test('TH_StaticPointers02', [], compile_fail, [''])
-test('T8759', normal, compile_fail, ['-v0'])
+test('T8759', normal, compile, ['-v0'])
 test('T7021',
      extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile,
      ['T7021','-v0 ' + config.ghc_th_way_flags])
@@ -393,7 +393,6 @@ test('T10819',
 test('T10820', normal, compile_and_run, ['-v0'])
 test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
-
 test('TH_finalizer', normal, compile, ['-v0'])
 test('T10603', normal, compile, ['-ddump-splices -dsuppress-uniques'])
 test('T11452', normal, compile_fail, ['-v0'])
@@ -405,3 +404,4 @@ test('T11809', normal, compile, ['-v0'])
 test('T11797', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T11941', normal, compile_fail, ['-v0'])
 test('T11484', normal, compile, ['-v0'])
+test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])