diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 29c64a2d2cf8a40068cea3541d59d3af09943fdf..221580cc1ea886ce57bde2c4ac4e8fd1f43af053 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -87,7 +87,7 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
- drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+ drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)
drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
drop_ty (HsDocTy _ a _) = drop_ty $ unL a
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index eb524ec70c325cd09c5acccdd625b18d1ea9c7ba..349c6e8e45e41bda236f6ae4acf17db3fbcc1491 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import Haddock.GhcUtils
import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty
-import GHC.Types.Basic ( PromotionFlag(..) )
+import GHC.Types.Basic ( PromotionFlag(..), isPromoted )
import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name ( nameOccName )
@@ -1133,9 +1133,13 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
= hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
- = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode
+ = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode
where
+ ppr_op_prom | isPromoted prom
+ = char '\'' <> ppr_op
+ | otherwise
+ = ppr_op
ppr_op | isSymOcc (getOccName op) = ppLDocName op
| otherwise = char '`' <> ppLDocName op <> char '`'
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 336f23ac588787ef6004c3c697004c514da15f51..a54bb0aa94d4027bffe14f57e282f8352409f7e0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1281,15 +1281,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _
= hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts
, atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
- = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _
+ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
where
- -- `(:)` is valid in type signature only as constructor to promoted list
- -- and needs to be quoted in code so we explicitly quote it here too.
- ppr_op
- | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'
- | otherwise = ppr_op'
- ppr_op' = ppLDocName qual Infix op
+ ppr_op_prom
+ | isPromoted prom
+ = promoQuote ppr_op
+ | otherwise
+ = ppr_op
+ ppr_op = ppLDocName qual Infix op
ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts
= parens (ppr_mono_lty ty unicode qual emptyCtxts)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 29e0957b0d9612dd1151c929066d4227e336898a..fd5300d245e8229bb12ba7926dc69f18c0d16696 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -606,7 +606,7 @@ synifyType _ vs (TyConApp tc tys)
tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy
-> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
| otherwise
- -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy
+ -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
@@ -615,14 +615,16 @@ synifyType _ vs (TyConApp tc tys)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
- = noLocA $ HsOpTy noExtField
+ = noLocA $ HsOpTy noAnn
+ NotPromoted
(synifyType WithinType vs ty1)
(noLocA eqTyConName)
(synifyType WithinType vs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
- = mk_app_tys (HsOpTy noExtField
+ = mk_app_tys (HsOpTy noAnn
+ prom
(synifyType WithinType vs ty1)
(noLocA $ getName tc)
(synifyType WithinType vs ty2))
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 9f9120fa43ef9671aeeff367ef428b87cb4b710d..7c1dc73b55b34e1dcb611a836081e5e85f7e11a3 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -229,7 +229,7 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty })
- extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
+ extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0)
add_ctxt (L loc preds) = L loc (extra_pred : preds)
@@ -365,8 +365,8 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
go p (HsAppKindTy x fun_ty arg_ki)
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
- go p (HsOpTy x ty1 op ty2)
- = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
+ go p (HsOpTy x prom ty1 op ty2)
+ = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2)
go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
go _ t@HsTyVar{} = t
go _ t@HsStarTy{} = t
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f2b3a9fa6102e4268972190a8138ccfe3aa25cfd..6057bf75c80619a56420efac78505bf12a1232cf 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -290,11 +290,11 @@ renameType t = case t of
HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
- HsOpTy _ a (L loc op) b -> do
+ HsOpTy _ prom a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy noAnn a' (L loc op') b')
+ return (HsOpTy noAnn prom a' (L loc op') b')
HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 399e5d0dac12455f0d36060afa49a6cd8d622a02..d116485873ad29df63fa4400c3e465c6b18f3440 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -16,6 +16,7 @@ import Haddock.Syb
import Haddock.Types
import GHC
+import GHC.Types.Basic ( PromotionFlag(..) )
import GHC.Types.Name
import GHC.Data.FastString
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
@@ -132,8 +133,8 @@ sugarTuples typ =
sugarOperators :: HsType GhcRn -> HsType GhcRn
-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
- | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)
+ | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb
| unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
where
name' = getName name
@@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
-renameType (HsOpTy x la lop lb) =
- HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
+renameType (HsOpTy x prom la lop lb) =
+ HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk