haskell · alexbiehl · Aug 6, 2017 · Aug 5, 2017 · Aug 5, 2017 · Aug 6, 2017
diff --git a/CHANGES.md b/CHANGES.md
@@ -6,6 +6,11 @@
 
  * Move markup related data types to haddock-library
 
+ * Fix: Show empty constraint contexts in pattern type signatures (#663)
+
+ * Fix: Generate constraint signatures for constructors exported as pattern
+   synonyms (#663)
+
 ## Changes in version 2.18.1
 
  * Synopsis is working again (#599)

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
@@ -985,7 +985,9 @@ extractDecl name decl
                                          O.$$ O.nest 4 (O.ppr matches))
       TyClD d@DataDecl {} ->
         let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
-        in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+        in if isDataConName name
+           then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+           else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
       InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
                                           , dfid_pats = HsIB { hsib_body = tys }
                                           , dfid_defn = defn }) ->
@@ -1003,6 +1005,36 @@ extractDecl name decl
           _ -> error "internal: extractDecl (ClsInstD)"
       _ -> error "internal: extractDecl"
 
+extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name
+extractPatternSyn nm t tvs cons =
+  case filter matches cons of
+    [] -> error "extractPatternSyn: constructor pattern not found"
+    con:_ -> extract <$> con
+ where
+  matches :: LConDecl Name -> Bool
+  matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
+  extract :: ConDecl Name -> Sig Name
+  extract con =
+    let args =
+          case getConDetails con of
+            PrefixCon args' -> args'
+            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+            InfixCon arg1 arg2 -> [arg1, arg2]
+        typ = longArrow args (data_ty con)
+        typ' =
+          case con of
+            ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+            _ -> typ
+        typ'' = noLoc (HsQualTy (noLoc []) typ')
+    in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+
+  longArrow :: [LHsType name] -> LHsType name -> LHsType name
+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+
+  data_ty con
+    | ConDeclGADT{} <- con = hsib_body $ con_type con
+    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+
 extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
               -> LSig Name
 extractRecSel _ _ _ [] = error "extractRecSel: selector not found"

diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
@@ -579,6 +579,12 @@ makeModuleQual qual aliases mdl =
     OptFullQual       -> FullQual
     OptNoQual         -> NoQual
 
+-- | Whether to hide empty contexts
+-- Since pattern synonyms have two contexts with different semantics, it is
+-- important to all of them, even if one of them is empty.
+data HideEmptyContexts
+  = HideEmptyContexts
+  | ShowEmptyToplevelContexts
 
 -----------------------------------------------------------------------------
 -- * Error handling

diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html
@@ -0,0 +1,124 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >ConstructorPatternExport</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>ConstructorPatternExport</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:FooCons" class="def"
+	    >FooCons</a
+	    > :: <a href="#"
+	    >String</a
+	    > -&gt; a -&gt; Foo a <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:MyRecCons" class="def"
+	    >MyRecCons</a
+	    > :: <a href="#"
+	    >Bool</a
+	    > -&gt; <a href="#"
+	    >Int</a
+	    > -&gt; MyRec <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v::-43-" class="def"
+	    >(:+)</a
+	    > :: <a href="#"
+	    >String</a
+	    > -&gt; a -&gt; MyInfix a <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:BlubCons" class="def"
+	    >BlubCons</a
+	    > :: () =&gt; <a href="#"
+	    >Show</a
+	    > b =&gt; b -&gt; Blub <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:MyGADTCons" class="def"
+	    >MyGADTCons</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > a. <a href="#"
+	    >Eq</a
+	    > a =&gt; a -&gt; <a href="#"
+	    >Int</a
+	    > -&gt; MyGADT (<a href="#"
+	    >Maybe</a
+	    > <a href="#"
+	    >String</a
+	    >) <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
@@ -99,6 +99,28 @@
 	    >FooType</a
 	    > x1))</li
 	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >BlubType</a
+	    > = <a href="#"
+	    >Show</a
+	    > x =&gt; <a href="#"
+	    >BlubCtor</a
+	    > x</li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a href="#"
+	    >Blub</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > x. <a href="#"
+	    >Show</a
+	    > x =&gt; x -&gt; <a href="#"
+	    >BlubType</a
+	    ></li
+	  ><li class="src short"
 	  ><span class="keyword"
 	    >data</span
 	    > (a :: <a href="#"
@@ -234,6 +256,60 @@
 	    ></div
 	  ></div
 	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:BlubType" class="def"
+	    >BlubType</a
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >BlubType is existentially quantified</p
+	    ></div
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a href="#"
+		  >Show</a
+		  > x =&gt; <a id="v:BlubCtor" class="def"
+		  >BlubCtor</a
+		  > x</td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:Blub" class="def"
+	    >Blub</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > x. <a href="#"
+	    >Show</a
+	    > x =&gt; x -&gt; <a href="#"
+	    >BlubType</a
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Pattern synonym for <code
+	      ><a href="#"
+		>Blub</a
+		></code
+	      > x</p
+	    ></div
+	  ></div
+	><div class="top"
 	><p class="src"
 	  ><span class="keyword"
 	    >data</span

diff --git a/html-test/src/ConstructorPatternExport.hs b/html-test/src/ConstructorPatternExport.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+module ConstructorPatternExport (
+    pattern FooCons
+  , pattern MyRecCons
+  , pattern (:+)
+  , pattern BlubCons
+  , pattern MyGADTCons
+  ) where
+
+data Foo a = FooCons String a
+
+data MyRec = MyRecCons { one :: Bool, two :: Int }
+
+data MyInfix a = String :+ a
+
+data Blub = forall b. Show b => BlubCons b
+
+data MyGADT :: * -> * where
+  MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String)
+
+pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String)
+pattern MyGADTCons' x y = MyGADTCons x y
diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms, PolyKinds, TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-}
 
 -- | Testing some pattern synonyms
 module PatternSyns where
@@ -15,6 +15,12 @@ pattern Bar x = FooCtor (Foo x)
 -- | Pattern synonym for (':<->')
 pattern x :<-> y = (Foo x, Bar y)
 
+-- | BlubType is existentially quantified
+data BlubType = forall x. Show x => BlubCtor x
+
+-- | Pattern synonym for 'Blub' x
+pattern Blub x = BlubCtor x
+
 -- | Doc for ('><')
 data (a :: *) >< b = Empty