aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2020-12-28 18:03:18 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2020-12-29 10:50:02 +0300
commit39a2def15c0d38bb1f7eef6db81676dd13785982 (patch)
tree45acda4dab1b8f153c4fabddc1836eedf0fbe427 /haddock-api
parent8a5ccf93c53a40abe42134c2282ac9b9d653224c (diff)
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.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs22
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs30
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