Inline and fix getGADTConTypeG

The getGADTConTypeG used HsRecTy, which is at odds with GHC issue #18782.

I noticed that getGADTConTypeG was only used in the Hoogle backend.
Interestingly, when handling H98 constructors, Hoogle converts RecCon to
PrefixCon (see Haddock.Backends.Hoogle.ppCtor).

So I changed getGADTConTypeG to handle RecConGADT in the same manner as
PrefixConGADT, and after this simplification moved it into the 'where'
clause of ppCtor, to the only place where it is used.

The practical effect of this change is as follows.
Consider this example:
	data TestH98 = T98 { bar::Int }
	data TestGADT where
	  TG :: { foo :: Int } -> TestGADT

Before this patch,  haddock --hoogle  used to produce:
	T98 :: Int -> TestH98
	[TG] :: {foo :: Int} -> TestGADT

Notice how the record syntax was discarded in T98 but not TG.
With this patch, we always produce signatures without record syntax:
	T98 :: Int -> TestH98
	[TG] :: Int -> TestGADT

I suspect this might also be a bugfix, as currently Hoogle doesn't seem
to render GADT record constructors properly.

2 files changed, 16 insertions, 36 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 947ce51b..520b51f3 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -271,13 +271,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
                         (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
                         map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
 
-ppCtor dflags _dat subdocs con@(ConDeclGADT { })
-   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
+                                        , con_bndrs = L _ outer_bndrs
+                                        , con_mb_cxt = mcxt
+                                        , con_g_args = args
+                                        , con_res_ty = res_ty })
+   = concatMap (lookupCon dflags subdocs) names ++ [typeSig]
     where
-        f = [typeSig name (getGADTConTypeG con)]
-
-        typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty)
-        name = out dflags $ map unL $ getConNames con
+        typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty
+        name = out dflags $ map unL names
+        con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
+          theta_ty = case mcxt of
+            Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+            Nothing -> tau_ty
+          tau_ty = foldr mkFunTy res_ty $
+            case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
+                         RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
+          mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
 ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 42dc7f4f..452cb6f4 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -185,36 +185,6 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln
 tcdNameI :: TyClDecl DocNameI -> DocName
 tcdNameI = unLoc . tyClDeclLNameI
 
--- -------------------------------------
-
-getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn
--- The full type of a GADT data constructor We really only get this in
--- order to pretty-print it, and currently only in Haddock's code.  So
--- we are cavalier about locations and extensions, hence the
--- 'undefined's
-getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs
-                            , con_mb_cxt = mcxt, con_g_args = args
-                            , con_res_ty = res_ty })
- = noLoc (HsSig { sig_ext   = noExtField
-                , sig_bndrs = outer_bndrs
-                , sig_body  = theta_ty })
- where
-   theta_ty | Just theta <- mcxt
-            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
-            | otherwise
-            = tau_ty
-
---   tau_ty :: LHsType DocNameI
-   tau_ty = case args of
-              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-
-   -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
-   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
-
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-  -- Should only be called on ConDeclGADT
-
 
 -------------------------------------------------------------------------------
 -- * Parenthesization