Fix: Generate pattern signatures for constructors exported as patterns (#663)

* Fix pretty-printing of pattern signatures

Pattern synonyms can have up to two contexts, both having a
different semantic meaning: The first holds the constraints
required to perform the matching, the second contains the
constraints provided by a successful pattern match. When the
first context is empty but the second is not it is necessary
to render the first, empty context.

* Generate pattern synonym signatures for ctors exported as patterns

This fixes #653.

* Simplify extractPatternSyn

It is not necessary to generate the simplest type signature since
it will be simplified when pretty-printed.

* Add changelog entries for PR #663

* Fix extractPatternSyn error message

1 files changed, 33 insertions, 1 deletions

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b9179d11..89f7f71b 100644
--- 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"