From bfb3563f730fd1c973a6611a0fba3435fb1df489 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Sat, 3 Jun 2017 20:37:28 +0200
Subject: Allow user defined signatures for pattern synonyms (#631)

---
 CHANGES.md                                  |  2 ++
 haddock-api/src/Haddock/GhcUtils.hs         |  5 +++++
 haddock-api/src/Haddock/Interface/Create.hs |  1 +
 html-test/ref/PatternSyns.html              | 29 +++++++++++++++++++++++++++++
 html-test/src/PatternSyns.hs                |  5 +++++
 5 files changed, 42 insertions(+)

diff --git a/CHANGES.md b/CHANGES.md
index 6c2b5d32..95e1763a 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,5 +1,7 @@
 ## Changes in version 2.18.0
 
+ * Support user defined signatures on pattern synonyms
+
  * Synopsis is working again (#599)
 
 ## Changes in version 2.17.4
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index dcc1d834..4280cd80 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -88,6 +88,10 @@ filterSigNames p (ClassOpSig is_default ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
     filtered -> Just (ClassOpSig is_default filtered ty)
+filterSigNames p (PatSynSig ns ty) =
+  case filter (p . unLoc) ns of
+    []       -> Nothing
+    filtered -> Just (PatSynSig filtered ty)
 filterSigNames _ _                           = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -110,6 +114,7 @@ sigNameNoLoc _                         = []
 isUserLSig :: LSig name -> Bool
 isUserLSig (L _(TypeSig {}))    = True
 isUserLSig (L _(ClassOpSig {})) = True
+isUserLSig (L _(PatSynSig {}))  = True
 isUserLSig _                    = False
 
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 26ac0281..98d4dbe8 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -842,6 +842,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     expandSig :: Sig name -> [Sig name]
     expandSig (TypeSig names t)      = [ TypeSig [n] t      | n <- names ]
     expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]
+    expandSig (PatSynSig names t)    = [ PatSynSig [n] t    | n <- names ]
     expandSig x                      = [x]
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index 9f0caaa2..2cf936b3 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -118,6 +118,16 @@ window.onload = function () {pageLoad();};
 	    > k a (b :: k). <a href="#"
 	    >(&gt;&lt;)</a
 	    > k a b</li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a href="#"
+	    >PatWithExplicitSig</a
+	    > :: <a href="#"
+	    >Eq</a
+	    > somex =&gt; somex -&gt; <a href="#"
+	    >FooType</a
+	    > somex</li
 	  ></ul
 	></div
       ><div id="interface"
@@ -279,6 +289,25 @@ window.onload = function () {pageLoad();};
 	      ></p
 	    ></div
 	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:PatWithExplicitSig" class="def"
+	    >PatWithExplicitSig</a
+	    > :: <a href="#"
+	    >Eq</a
+	    > somex =&gt; somex -&gt; <a href="#"
+	    >FooType</a
+	    > somex <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Earlier ghc versions didn't allow explicit signatures
+ on pattern synonyms.</p
+	    ></div
+	  ></div
 	></div
       ></div
     ><div id="footer"
diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs
index 8af5eb23..a8de113c 100644
--- a/html-test/src/PatternSyns.hs
+++ b/html-test/src/PatternSyns.hs
@@ -20,3 +20,8 @@ data (a :: *) >< b = Empty
 
 -- | Pattern for 'Empty'
 pattern E = Empty
+
+-- | Earlier ghc versions didn't allow explicit signatures
+-- on pattern synonyms.
+pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex
+pattern PatWithExplicitSig x = FooCtor x
-- 
cgit v1.2.3