Implement type applications in patterns

The haddock submodule is also updated so that it understands the changes
to patterns.

5 files changed, 22 insertions, 8 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 505b9125bc..1f8175a735 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -162,6 +162,8 @@ import Language.Haskell.TH.Lib.Internal hiding
   , tupE
   , unboxedTupE
 
+  , conP
+
   , Role
   , InjectivityAnn
   )
@@ -349,3 +351,9 @@ doE = Internal.doE Nothing
 
 mdoE :: Quote m => [m Stmt] -> m Exp
 mdoE = Internal.mdoE Nothing
+
+-------------------------------------------------------------------------------
+-- * Patterns
+
+conP :: Quote m => Name -> [m Pat] -> m Pat
+conP n xs = Internal.conP n [] xs
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index fa38e6a933..ed1aa022c5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -125,9 +125,10 @@ unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)}
 unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat
 unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) }
 
-conP :: Quote m => Name -> [m Pat] -> m Pat
-conP n ps = do ps' <- sequenceA ps
-               pure (ConP n ps')
+conP :: Quote m => Name -> [m Type] -> [m Pat] -> m Pat
+conP n ts ps = do ps' <- sequenceA ps
+                  ts' <- sequenceA ts
+                  pure (ConP n ts' ps')
 infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
 infixP p1 n p2 = do p1' <- p1
                     p2' <- p2
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 92b2238f72..b19c74f6fb 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -304,13 +304,15 @@ pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
 pprPat i (TupP ps)
   | [_] <- ps
-  = pprPat i (ConP (tupleDataName 1) ps)
+  = pprPat i (ConP (tupleDataName 1) [] ps)
   | otherwise
   = parens (commaSep ps)
 pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
 pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
-pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
-                                              <+> sep (map (pprPat appPrec) ps)
+pprPat i (ConP s ts ps)  = parensIf (i >= appPrec) $
+      pprName' Applied s
+  <+> sep (map (\t -> char '@' <> pprParendType t) ts)
+  <+> sep (map (pprPat appPrec) ps)
 pprPat _ (ParensP p)  = parens $ pprPat noPrec p
 pprPat i (UInfixP p1 n p2)
                       = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 9c47b6cfdd..a3104ed684 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1296,7 +1296,7 @@ dataToPatQ = dataToQa id litP conP
             case nameSpace n of
                 Just DataName -> do
                     ps' <- sequence ps
-                    return (ConP n ps')
+                    return (ConP n [] ps')
                 _ -> error $ "Can't construct a pattern from name "
                           ++ showName n
 
@@ -2018,7 +2018,7 @@ data Pat
   | TupP [Pat]                      -- ^ @{ (p1,p2) }@
   | UnboxedTupP [Pat]               -- ^ @{ (\# p1,p2 \#) }@
   | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@
-  | ConP Name [Pat]                 -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
+  | ConP Name [Type] [Pat]          -- ^ @data T1 = C1 t1 t2; {C1 \@ty1 p1 p2} = e@
   | InfixP Pat Name Pat             -- ^ @foo ({x :+ y}) = e@
   | UInfixP Pat Name Pat            -- ^ @foo ({x :+ y}) = e@
                                     --
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 8cd88b5ccc..356f651fd5 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -34,6 +34,9 @@
 
   * The argument to `TExpQ` can now be levity polymorphic.
 
+  * The types of `ConP` and `conP` have been changed to allow for an additional list
+    of type applications preceding the argument patterns.
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and