Allow one type signature for multiple pattern synonyms

This makes pattern synonym signatures more consistent with normal
type signatures.

Updates haddock submodule.

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

11 files changed, 34 insertions, 21 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 9e13b8665c..8dd8b48488 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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 loc (PatSynSig nm ty))     = (:[]) <$> rep_patsyn_ty_sig loc ty nm
+rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms
 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
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 8d85ca9332..ad51f9d4b9 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -375,7 +375,7 @@ cvtDec (TH.PatSynD nm args dir pat)
 cvtDec (TH.PatSynSigD nm ty)
   = do { nm' <- cNameL nm
        ; ty' <- cvtPatSynSigTy ty
-       ; returnJustL $ Hs.SigD $ PatSynSig nm' (mkLHsSigType ty') }
+       ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
 
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 5383ee5c6b..8772619e85 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -705,7 +705,7 @@ data Sig name
       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-  | PatSynSig (Located name) (LHsSigType name)
+  | PatSynSig [Located name] (LHsSigType name)
       -- P :: forall a b. Req => Prov => ty
 
       -- | A signature for a class method
@@ -901,9 +901,8 @@ ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLo
 ppr_sig (SpecInstSig _ ty)
   = pragBrackets (text "SPECIALIZE instance" <+> ppr ty)
 ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name sig_ty)
-  = text "pattern" <+> pprPrefixOcc (unLoc name) <+> dcolon
-                           <+> ppr sig_ty
+ppr_sig (PatSynSig names sig_ty)
+  = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index b0b64aea5c..e8d60ec611 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1194,8 +1194,8 @@ where_decls :: { Located ([AddAnn]
                                           ,sL1 $3 (snd $ unLoc $3)) }
 
 pattern_synonym_sig :: { LSig RdrName }
-        : 'pattern' con '::' sigtype
-                   {% ams (sLL $1 $> $ PatSynSig $2 (mkLHsSigType $4))
+        : 'pattern' con_list '::' sigtype
+                   {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4))
                           [mj AnnPattern $1, mu AnnDcolon $3] }
 
 -----------------------------------------------------------------------------
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 0466de375e..f6c18b41c5 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -558,8 +558,8 @@ mkSigTvFn sigs
       = add_scoped_tvs names (hsScopedTvs sig_ty) env
     add_scoped_sig (L _ (TypeSig names sig_ty)) env
       = add_scoped_tvs names (hsWcScopedTvs sig_ty) env
-    add_scoped_sig (L _ (PatSynSig name sig_ty)) env
-      = add_scoped_tvs [name] (hsScopedTvs sig_ty) env
+    add_scoped_sig (L _ (PatSynSig names sig_ty)) env
+      = add_scoped_tvs names (hsScopedTvs sig_ty) env
     add_scoped_sig _ env = env
 
     add_scoped_tvs :: [Located Name] -> [Name] -> NameEnv [Name] -> NameEnv [Name]
@@ -925,13 +925,13 @@ renameSig ctxt sig@(MinimalSig s (L l bf))
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
        return (MinimalSig s (L l new_bf), emptyFVs)
 
-renameSig ctxt sig@(PatSynSig v ty)
-  = do  { v' <- lookupSigOccRn ctxt sig v
+renameSig ctxt sig@(PatSynSig vs ty)
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
         ; (ty', fvs) <- rnHsSigType ty_ctxt ty
-        ; return (PatSynSig v' ty', fvs) }
+        ; return (PatSynSig new_vs ty', fvs) }
   where
     ty_ctxt = GenericCtx (text "a pattern synonym signature for"
-                          <+> quotes (ppr v))
+                          <+> ppr_sig_bndrs vs)
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index be301f3ba1..b8a5c28036 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -601,7 +601,7 @@ getTypeSigNames sigs
     get_type_sig sig ns =
       case sig of
         L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
-        L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
+        L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
         _ -> ns
 
 
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index 6587cb01d4..bcf8b9e5a7 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -196,10 +196,11 @@ tcTySig (L loc (TypeSig names sig_ty))
                           | L _ name <- names ]
        ; return (map TcIdSig sigs) }
 
-tcTySig (L loc (PatSynSig (L _ name) sig_ty))
+tcTySig (L loc (PatSynSig names sig_ty))
   = setSrcSpan loc $
-    do { tpsi <- tcPatSynSig name sig_ty
-       ; return [TcPatSynSig tpsi] }
+    do { tpsigs <- sequence [ tcPatSynSig name sig_ty
+                            | L _ name <- names ]
+       ; return (map TcPatSynSig tpsigs) }
 
 tcTySig _ = return []
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 45b0d1c256..6cf98830ba 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -4315,14 +4315,19 @@ Note also the following points
 -  You may specify an explicit *pattern signature*, as we did for
    ``ExNumPat`` above, to specify the type of a pattern, just as you can
    for a function. As usual, the type signature can be less polymorphic
-   than the inferred type. For example
-
-   ::
+   than the inferred type. For example ::
 
          -- Inferred type would be 'a -> [a]'
          pattern SinglePair :: (a, a) -> [(a, a)]
          pattern SinglePair x = [x]
 
+   Just like signatures on value-level bindings, pattern synonym signatures can
+   apply to more than one pattern. For instance, ::
+
+         pattern Left', Right' :: a -> Either a a
+         pattern Left' x  = Left x
+         pattern Right' x = Right x
+
 -  The GHCi :ghci-cmd:`:info` command shows pattern types in this format.
 
 -  For a bidirectional pattern synonym, a use of the pattern synonym as
diff --git a/testsuite/tests/patsyn/should_compile/T11727.hs b/testsuite/tests/patsyn/should_compile/T11727.hs
new file mode 100644
index 0000000000..7f5d7eb3cd
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T11727.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T11727 where
+
+pattern A,B :: Int
+pattern A = 5
+pattern B = 5
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index ff2f14afa1..f29e56e790 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -52,6 +52,7 @@ test('T11336', normal, compile, [''])
 test('T11367', normal, compile, [''])
 test('T11351', normal, compile, [''])
 test('T11633', normal, compile, [''])
+test('T11727', normal, compile, [''])
 test('T11959', expect_broken(11959), multimod_compile, ['T11959', '-v0'])
 test('T12094', normal, compile, [''])
 test('T11977', normal, compile, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject f833ba8cdbe6ea9436f9f7bf79494a968e8394f
+Subproject 008e61d0c4b10713751c2a1de4958acc7536739