aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/GhcUtils.hs
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2020-09-23 20:37:34 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2020-10-30 19:35:59 -0400
commitad9cbad7312a64e6757c32bd9488c55ba4f2fec9 (patch)
tree1c0035b3bf571673c539aad1b992a8a392d7bf4b /haddock-api/src/Haddock/GhcUtils.hs
parent3cce1bdee8c61bb6daa089059e12435178f50770 (diff)
Adapt to HsOuterTyVarBndrs
These changes accompany ghc/ghc!4107, which aims to be a fix for #16762.
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs76
1 files changed, 50 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index d6d12e4e..39d6d3fd 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -123,30 +123,28 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
getConNamesI ConDeclGADT {con_names = names} = names
-hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
-hsImplicitBodyI (HsIB { hsib_body = body }) = body
-
-hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
-hsSigTypeI = hsImplicitBodyI
-
mkHsForAllInvisTeleI ::
[LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI invis_bndrs =
HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
-getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
+mkHsImplicitSigTypeI body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}
+ , sig_body = body }
+
+getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
-- 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
-getGADTConType (ConDeclGADT { con_forall = L _ has_forall
- , con_qvars = qtvs
+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTeleI qtvs
- , hst_body = theta_ty })
- | otherwise = theta_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 })
@@ -188,19 +186,17 @@ tcdNameI = unLoc . tyClDeclLNameI
-- -------------------------------------
-getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
+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_forall = L _ has_forall
- , con_qvars = qtvs
+getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTele qtvs
- , hst_body = theta_ty })
- | otherwise = theta_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 })
@@ -244,7 +240,9 @@ data Precedence
--
-- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(.
-reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
@@ -294,15 +292,37 @@ reparenTypePrec = go
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a
+reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
+reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => LHsType a -> LHsType a
reparenLType = mapXRec @a reparenType
+-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
+reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsSigType a -> HsSigType a
+reparenSigType (HsSig x bndrs body) =
+ HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
+reparenSigType v@XHsSigType{} = v
+
+-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
+reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)
+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
+
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a)
+reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
=> HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) =
HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
@@ -311,13 +331,17 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c