Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 9831385b by Vladislav Zavialov at 2026-03-27T17:22:30-04:00 Infix holes in types (#11107) This patch introduces several improvements that follow naturally from refactoring HsOpTy to represent the operator as an HsType, aligning it with the approach taken by OpApp and HsExpr. User-facing changes: 1. Infix holes (t1 `_` t2) are now permitted in types, following the precedent set by term-level expressions. Test case: T11107 2. Error messages for illegal promotion ticks are now reported at more precise source locations. Test case: T17865 Internal changes: * The definition of HsOpTy now mirrors that of OpApp: | HsOpTy (XOpTy p) (LHsType p) (LHsType p) (LHsType p) | OpApp (XOpApp p) (LHsExpr p) (LHsExpr p) (LHsExpr p) This moves us one step closer to unifying HsType and HsExpr. * Ignoring locations, the old pattern match (HsOpTy x prom lhs op rhs) is now written as (HsOpTy x lhs (HsTyVar x' prom op) rhs) but we also handle (HsOpTy x lhs (HsWildCardTy x') rhs) Constructors other than HsTyVar and HsWildCardTy never appear in the operator position. * The various definitions across the compiler have been updated to work with the new representation, drawing inspiration from the term-level pipeline where appropriate. For example, ppr_infix_ty <=> ppr_infix_expr get_tyop <=> get_op lookupTypeFixityRn <=> lookupExprFixityRn (the latter is factored out from rnExpr) Test cases: T11107 T17865 - - - - - 30 changed files: - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Fixity.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Type.hs - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_fail/T17865.stderr - + testsuite/tests/partial-sigs/should_compile/T11107.hs - + testsuite/tests/partial-sigs/should_compile/T11107.stderr - testsuite/tests/partial-sigs/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -683,11 +683,12 @@ ignoreParens ty = ty mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs mkAnonWildCardTy tok = HsWildCardTy tok -mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) +mkHsOpTy :: (Anno (IdOccGhcP p) ~ EpAnn a) => PromotionFlag - -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p)) + -> LHsType (GhcPass p) -> LIdOccP (GhcPass p) -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2 +mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField ty1 tyop ty2 + where tyop = L (l2l op) $ HsTyVar noAnn prom op mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2) @@ -745,7 +746,7 @@ hsTyGetAppHead_maybe = go go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l go (L _ (HsAppKindTy _ t _)) = go t - go (L _ (HsOpTy _ _ _ ln _)) = Just ln + go (L _ (HsOpTy _ _ op _)) = go op go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t go _ = Nothing @@ -1457,9 +1458,14 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k -ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) - = sep [ ppr_mono_lty ty1 - , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ] +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) + | Just pp_op <- ppr_infix_ty tyop + = sep [pp_ty1, sep [pp_op, pp_ty2]] + | otherwise -- This shouldn't happen unless the user constructs weird ASTs via the GHC API + = hang (ppr tyop) 2 (sep [pp_ty1, pp_ty2]) + where + pp_ty1 = ppr_mono_lty ty1 + pp_ty2 = ppr_mono_lty ty2 ppr_mono_ty (HsParTy _ ty) = parens (ppr_mono_lty ty) -- Put the parens in where the user did @@ -1476,6 +1482,11 @@ ppr_mono_ty (XHsType t) = case ghcPass @p of HsRecTy _ flds -> pprHsConDeclRecFields flds GhcRn -> ppr t +ppr_infix_ty :: (OutputableBndrId p) => LHsType (GhcPass p) -> Maybe SDoc +ppr_infix_ty (L _ (HsTyVar _ prom (L _ op))) = Just (pprOccWithTick Infix prom op) +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`") +ppr_infix_ty _ = Nothing + -------------------------- ppr_fun_ty :: (OutputableBndrId p) => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -632,7 +632,7 @@ nlHsTyConApp :: forall p a. IsSrcSpanAnn p a nlHsTyConApp prom fixity tycon tys | Infix <- fixity , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys - = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest + = foldl' mk_app (noLocA $ mkHsOpTy prom ty1 (noLocA tycon) ty2) rest | otherwise = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys where ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1473,8 +1473,7 @@ repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys repTy (HsSumTy _ tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) +repTy (HsOpTy _ ty1 op ty2) = repLTy ((op `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy _ t) = repLTy t repTy (HsStarTy _) = repTStar repTy (HsKindSig _ t k) = do ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1922,9 +1922,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsSumTy _ tys -> [ toHie tys ] - HsOpTy _ _prom a op b -> + HsOpTy _ a op b -> [ toHie a - , toHie $ C Use op + , toHie op , toHie b ] HsParTy _ a -> ===================================== compiler/GHC/Parser.y ===================================== @@ -2316,15 +2316,14 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) } : ftype %shift { $1 } | ftype tyop infixtype { $1 >>= \ $1 -> $3 >>= \ $3 -> - do { let (op, prom) = $2 - ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op) - ; mkHsOpTyPV prom $1 op $3 } } + do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2) + ; mkHsOpTyPV $1 $2 $3 } } | unpackedness infixtype { $2 >>= \ $2 -> mkUnpackednessPV $1 $2 } ftype :: { forall b. DisambTD b => PV (LocatedA b) } : atype { mkHsAppTyHeadPV $1 } - | tyop { failOpFewArgs (fst $1) } + | tyop { failOpFewArgs $1 } | ftype tyarg { $1 >>= \ $1 -> mkHsAppTyPV $1 $2 } | ftype PREFIX_AT atype { $1 >>= \ $1 -> @@ -2334,15 +2333,12 @@ tyarg :: { LHsType GhcPs } : atype { $1 } | unpackedness atype {% addUnpackednessP $1 $2 } -tyop :: { (LocatedN RdrName, PromotionFlag) } - : qtyconop { ($1, NotPromoted) } - | tyvarop { ($1, NotPromoted) } - | SIMPLEQUOTE qconop {% do { op <- amsr (sLL $1 $> (unLoc $2)) - (NameAnnQuote (epTok $1) (gl $2) []) - ; return (op, IsPromoted) } } - | SIMPLEQUOTE varop {% do { op <- amsr (sLL $1 $> (unLoc $2)) - (NameAnnQuote (epTok $1) (gl $2) []) - ; return (op, IsPromoted) } } +tyop :: { LHsType GhcPs } + : qtyconop { sL1a $1 (HsTyVar noAnn NotPromoted $1) } + | tyvarop { sL1a $1 (HsTyVar noAnn NotPromoted $1) } + | SIMPLEQUOTE qconop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) } + | SIMPLEQUOTE varop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) } + | '`' '_' '`' { sLLa $1 $> (mkAnonWildCardTy (epTok $2)) } -- TODO: reuse hole_op (blocked on #27111) atype :: { LHsType GhcPs } : ntgtycon {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) } -- Not including unit tuples @@ -4475,12 +4471,12 @@ hintLinear span = do unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction -- Does this look like (a %m)? -looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool -looksLikeMult ty1 l_op ty2 - | Unqual op_name <- unLoc l_op +looksLikeMult :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> Bool +looksLikeMult ty1 tyop ty2 + | HsTyVar _ _ (L _ (Unqual op_name)) <- unLoc tyop , occNameFS op_name == fsLit "%" , Strict.Just ty1_pos <- getBufSpan (getLocA ty1) - , Strict.Just pct_pos <- getBufSpan (getLocA l_op) + , Strict.Just pct_pos <- getBufSpan (getLocA tyop) , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) , bufSpanEnd ty1_pos /= bufSpanStart pct_pos , bufSpanEnd pct_pos == bufSpanStart ty2_pos ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1140,8 +1140,8 @@ checkTyClHdr is_cls ty go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix | isRdrTc tc = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l) - go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix - | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l) + go cs l (HsOpTy _ t1 tyop t2) acc ops cps _fix + = goL (cs Semi.<> comments l) tyop (lhs:rhs:acc) ops cps Infix where lhs = HsValArg noExtField t1 rhs = HsValArg noExtField t2 go cs l (HsParTy (o,c) ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix @@ -2409,7 +2409,7 @@ class DisambTD b where -- | Disambiguate @f \@t@ (visible kind application) mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) - mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) + mkHsOpTyPV :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) @@ -2417,8 +2417,8 @@ instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) - mkHsOpTyPV prom t1 op t2 = do - let (L l ty) = mkLHsOpTy prom t1 op t2 + mkHsOpTyPV t1 tyop t2 = do + let (L l ty) = mkLHsOpTy t1 tyop t2 !cs <- getCommentsFor (locA l) return (L (addCommentsToEpAnn l cs) ty) mkUnpackednessPV = addUnpackednessP @@ -2460,11 +2460,11 @@ instance DisambTD DataConBuilder where addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $ (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) - mkHsOpTyPV prom lhs tc rhs = do + mkHsOpTyPV lhs op@(L _ (HsTyVar _ prom tc)) rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative data_con <- eitherToP $ tyConToDataCon tc !cs <- getCommentsFor (locA l) - checkNotPromotedDataCon prom data_con + checkNotPromotedDataCon (getLocA op) prom data_con return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs) where l = combineLocsA lhs rhs @@ -2473,6 +2473,9 @@ instance DisambTD DataConBuilder where addError $ mkPlainErrorMsgEnvelope (locA l) $ (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) check_no_ops _ = return () + mkHsOpTyPV _ (L l (HsWildCardTy _)) _ = + addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole + mkHsOpTyPV _ op _ = pprPanic "mkHsOpTyPV: impossible type operator" (ppr op) mkUnpackednessPV unpk constr_stuff | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff @@ -2488,7 +2491,7 @@ instance DisambTD DataConBuilder where tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) tyToDataConBuilder (L l (HsTyVar _ prom v)) = do data_con <- eitherToP $ tyConToDataCon v - checkNotPromotedDataCon prom data_con + checkNotPromotedDataCon (locA l) prom data_con return $ L l (PrefixDataConBuilder nilOL data_con) tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) @@ -2501,10 +2504,14 @@ tyToDataConBuilder t = (PsErrInvalidDataCon (unLoc t)) -- | Rejects declarations such as @data T = 'MkT@ (note the leading tick). -checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV () -checkNotPromotedDataCon NotPromoted _ = return () -checkNotPromotedDataCon IsPromoted (L l name) = - addError $ mkPlainErrorMsgEnvelope (locA l) $ +checkNotPromotedDataCon + :: SrcSpan -- ^ The enclosing SrcSpan containing the tick + -> PromotionFlag + -> LocatedN RdrName + -> PV () +checkNotPromotedDataCon _ NotPromoted _ = return () +checkNotPromotedDataCon loc IsPromoted (L _ name) = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalPromotionQuoteDataCon name mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs) @@ -3460,12 +3467,15 @@ failSpliceOrQuoteTwice lvl = warnStarIsType :: MonadP m => SrcSpan -> m () warnStarIsType span = addPsMessage span PsWarnStarIsType -failOpFewArgs :: MonadP m => LocatedN RdrName -> m a -failOpFewArgs (L loc op) = +failOpFewArgs :: MonadP m => LHsType GhcPs -> m a +failOpFewArgs (L _ (HsTyVar _ _ (L loc op))) = do { star_is_type <- getBit StarIsTypeBit ; let is_star_type = if star_is_type then StarIsType else StarIsNotType ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrOpFewArgs is_star_type op) } +failOpFewArgs (L l (HsWildCardTy _)) = + addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole +failOpFewArgs op = pprPanic "failOpFewArgs: impossible type operator" (ppr op) requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m () requireExplicitNamespaces kw = do @@ -3701,10 +3711,10 @@ mkSumOrTuplePat l Boxed a@Sum{} _ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a -mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs -mkLHsOpTy prom x op y = +mkLHsOpTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy x op y = let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y - in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y) + in L (noAnnSrcSpan loc) (HsOpTy noExtField x op y) mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -50,7 +50,6 @@ import GHC.Unit.Module ( isInteractiveModule ) import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel -import GHC.Types.Fixity import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set @@ -401,12 +400,7 @@ rnExpr (OpApp _ e1 op e2) -- we used to avoid fixity stuff, but we can't easily tell any -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate -- should prevent bad things happening. - ; fixity <- case op' of - L _ (HsVar _ (L _ (WithUserRdr _ n))) -> lookupFixityRn n - L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f - _ -> return (Fixity minPrecedence InfixL) - -- c.f. lookupFixity for unbound - + ; fixity <- lookupExprFixityRn op' ; lexical_negation <- xoptM LangExt.LexicalNegation ; let negation_handling | lexical_negation = KeepNegationIntact | otherwise = ReassociateNegation ===================================== compiler/GHC/Rename/Fixity.hs ===================================== @@ -11,7 +11,8 @@ module GHC.Rename.Fixity , lookupFixityRn , lookupFixityRn_help , lookupFieldFixityRn - , lookupTyFixityRn + , lookupExprFixityRn + , lookupTypeFixityRn ) where import GHC.Prelude @@ -26,6 +27,7 @@ import GHC.Unit.Module.ModIface import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Types.Name.Reader import GHC.Types.Fixity import GHC.Types.SrcLoc @@ -198,8 +200,19 @@ lookupFixityRn_help name doc = text "Checking fixity for" <+> ppr name --------------- -lookupTyFixityRn :: LocatedN Name -> RnM Fixity -lookupTyFixityRn = lookupFixityRn . unLoc - lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n) + +lookupExprFixityRn :: LHsExpr GhcRn -> RnM Fixity +lookupExprFixityRn e = + case e of + L _ (HsVar _ op) -> lookupFixityRn (unLocWithUserRdr op) + L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f + _ -> return (Fixity minPrecedence InfixL) + -- c.f. lookupFixity for unbound + +lookupTypeFixityRn :: LHsType GhcRn -> RnM Fixity +lookupTypeFixityRn t = + case t of + L _ (HsTyVar _ _ op) -> lookupFixityRn (unLocWithUserRdr op) + _ -> return (Fixity minPrecedence InfixL) ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -54,7 +54,7 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNames , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn - , lookupTyFixityRn ) + , lookupTypeFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr ( pprHsDocContext ) @@ -67,7 +67,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel -import GHC.Types.Error import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity ) @@ -551,16 +550,13 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) ; checkPromotedDataConName env tv Prefix ip name ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFV name) } -rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) - = setSrcSpan (getLocA l_op) $ - do { let op_rdr = unLoc l_op - ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op - ; let op_name = unLoc l_op' - ; fix <- lookupTyFixityRn l_op' +rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2) + = setSrcSpan (getLocA tyop) $ + do { (tyop', fvs1) <- rnHsTyOp env ty tyop + ; fix <- lookupTypeFixityRn tyop' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' - ; checkPromotedDataConName env ty Infix prom op_name + ; res_ty <- mkHsOpTyRn tyop' fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) @@ -770,15 +766,20 @@ rnLTyVar (L loc rdr_name) ; return (L loc tyvar) } -------------- -rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName - -> RnM (LocatedN Name, FreeVars) -rnHsTyOp env overall_ty (L loc op) +rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs + -> RnM (LHsType GhcRn, FreeVars) +rnHsTyOp env overall_ty tyop + | L l (HsTyVar ann prom (L loc op)) <- tyop = do { op' <- rnTyVar env op ; unlessXOptM LangExt.TypeOperators $ if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env then addDiagnostic TcRnTypeEqualityRequiresOperators - else addErr $ TcRnIllegalTypeOperator overall_ty op - ; return (L loc op', unitFV op') } + else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op + ; checkPromotedDataConName env overall_ty Infix prom op' + ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op'))) + ; return (tyop', unitFV op') } + | otherwise + = rnLHsTyKi env tyop -------------- checkWildCard :: RnTyKiEnv @@ -1400,33 +1401,33 @@ precedence and does not require rearrangement. --------------- -- Building (ty1 `op1` (ty2a `op2` ty2b)) -mkHsOpTyRn :: PromotionFlag - -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn +mkHsOpTyRn :: LHsType GhcRn + -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b)) - = do { fix2 <- lookupTyFixityRn (fmap getName op2) - ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } +mkHsOpTyRn tyop1 fix1 ty1 (L loc2 (HsOpTy _ ty2a tyop2 ty2b)) + = do { fix2 <- lookupTypeFixityRn tyop2 + ; mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangement - = return (HsOpTy noExtField prom1 ty1 op1 ty2) +mkHsOpTyRn tyop _ ty1 ty2 -- Default case, no rearrangement + = return (HsOpTy noExtField ty1 tyop ty2) --------------- -mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn - -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn +mk_hs_op_ty :: LHsType GhcRn -> Fixity -> LHsType GhcRn + -> LHsType GhcRn -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpanAnnA -> RnM (HsType GhcRn) -mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 - | nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1) - (NormalOp (unLoc op2),fix2) +mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2 + | nofix_error = do { precParseErr (get_tyop tyop1,fix1) + (get_tyop tyop2,fix2) ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) } | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b) - new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a + new_ty <- mkHsOpTyRn tyop1 fix1 ty1 ty2a ; return (noLocA new_ty `op2ty` ty2b) } where - lhs `op1ty` rhs = HsOpTy noExtField prom1 lhs op1 rhs - lhs `op2ty` rhs = HsOpTy noExtField prom2 lhs op2 rhs + lhs `op1ty` rhs = HsOpTy noExtField lhs tyop1 rhs + lhs `op2ty` rhs = HsOpTy noExtField lhs tyop2 rhs (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1493,6 +1494,11 @@ get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv get_op (L _ (XExpr (HsRecSelRn fld))) = RecFldOp fld get_op other = pprPanic "get_op" (ppr other) +get_tyop :: LHsType GhcRn -> OpName +get_tyop (L _ (HsTyVar _ _ n)) = NormalOp (unLoc n) +get_tyop (L _ (HsWildCardTy _)) = UnboundOp (Unqual (mkVarOcc "_")) +get_tyop other = pprPanic "get_tyop" (ppr other) + -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK @@ -2119,8 +2125,8 @@ extract_lty (L _ ty) acc extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables] extract_lty ty2 acc HsIParamTy _ _ ty -> extract_lty ty acc - HsOpTy _ _ ty1 tv ty2 -> extract_lty ty1 $ - extract_tv tv $ + HsOpTy _ ty1 op ty2 -> extract_lty ty1 $ + extract_lty op $ extract_lty ty2 acc HsParTy _ ty -> extract_lty ty acc HsSpliceTy {} -> acc -- Type splices mention no tvs ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -1314,6 +1314,16 @@ rn_ty_pat_var lrdr@(L l rdr) = do name <- lookupTypeOccTPRnM rdr pure (L l $ WithUserRdr rdr name) +rn_tyop_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) +rn_tyop_pat tyop + | L l (HsTyVar ann prom l_op) <- tyop + = do l_op' <- rn_ty_pat_var l_op + let op_name = getName l_op' + when (isDataConName op_name && not (isPromoted prom)) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + return (L l $ HsTyVar ann prom l_op') + | otherwise = rn_lty_pat tyop + -- | Rename type patterns -- -- For the difference between `rn_ty_pat` and `rnHsTyKi` see Note [CpsRn monad] @@ -1373,15 +1383,13 @@ rn_ty_pat (HsSumTy an tys) = do tys' <- mapM rn_lty_pat tys pure (HsSumTy an tys') -rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do +rn_ty_pat (HsOpTy _ ty1 tyop ty2) = do ty1' <- rn_lty_pat ty1 - l_op' <- rn_ty_pat_var l_op + tyop' <- rn_tyop_pat tyop ty2' <- rn_lty_pat ty2 - fix <- liftRn $ lookupTyFixityRn $ fmap getName l_op' - let op_name = getName l_op' - when (isDataConName op_name && not (isPromoted prom)) $ - liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) - liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2' + liftRn $ do + fix <- lookupTypeFixityRn tyop' + mkHsOpTyRn tyop' fix ty1' ty2' rn_ty_pat (HsParTy an ty) = do ty' <- rn_lty_pat ty ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1136,15 +1136,11 @@ expr_to_type earg = do { lhs' <- go lhs ; rhs' <- unwrap_wc rhs ; return (L l (HsAppKindTy noExtField lhs' rhs')) } - go (L l e@(OpApp _ lhs op rhs)) = + go (L l (OpApp _ lhs op rhs)) = do { lhs' <- go lhs ; op' <- go op ; rhs' <- go rhs - ; op_id <- unwrap_op_tv op' - ; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) } - where - unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id - unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e) + ; return (L l (HsOpTy noExtField lhs' op' rhs')) } go (L l (HsOverLit _ ol)) = do { let lit = tyLitFromOverloadedLit (ol_val ol) ; return (L l (HsTyLit noExtField lit)) } ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -103,7 +103,7 @@ import GHC.Core.TyCo.Ppr import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name.Env -import GHC.Types.Name.Reader( WithUserRdr(..), lookupLocalRdrOcc ) +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Types.Var.Set import GHC.Core.TyCon @@ -1146,8 +1146,9 @@ tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: inva tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind = tc_fun_type mode mult ty1 ty2 exp_kind -tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind - | op `hasKey` unrestrictedFunTyConKey +tcHsType mode (HsOpTy _ ty1 tyop ty2) exp_kind + | L _ (HsTyVar _ _ op) <- tyop + , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind --------- Foralls @@ -1531,12 +1532,15 @@ splitHsAppTys_maybe hs_ty is_app :: HsType GhcRn -> Bool is_app (HsAppKindTy {}) = True is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _) - = not (op `hasKey` unrestrictedFunTyConKey) + is_app (HsOpTy _ _ tyop _) + | L _ (HsTyVar _ _ op) <- tyop + , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey -- I'm not sure why this funTyConKey test is necessary -- Can it even happen? Perhaps for t1 `(->)` t2 -- but then maybe it's ok to treat that like a normal -- application rather than using the special rule for HsFunTy + = False + is_app (HsOpTy {}) = True is_app (HsTyVar {}) = True is_app (HsParTy _ (L _ ty)) = is_app ty is_app _ = False @@ -1552,9 +1556,8 @@ splitHsAppTys hs_ty = go (noLocA hs_ty) [] go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as) go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) - go (L _ (HsOpTy _ prom l op@(L sp _) r)) as - = ( L (l2l sp) (HsTyVar noAnn prom op) - , HsValArg noExtField l : HsValArg noExtField r : as ) + go (L _ (HsOpTy _ l tyop r)) as = + (tyop, HsValArg noExtField l : HsValArg noExtField r : as) go f as = (f, as) --------------------------- ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -549,7 +549,7 @@ pat_to_type (NPat _ (L _ ol) _ _) pat_to_type (ConPat _ lname (InfixCon left right)) = do { lty <- pat_to_type (unLoc left) ; rty <- pat_to_type (unLoc right) - ; let { t = noLocA (HsOpTy noExtField NotPromoted lty lname rty)} + ; let { t = noLocA (mkHsOpTy NotPromoted lty lname rty)} ; pure t } pat_to_type (ConPat _ lname (PrefixCon args)) = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname) } ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -292,7 +292,7 @@ no_anon_wc_ty lty = go lty HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys HsSumTy _ tys -> gos tys - HsOpTy _ _ ty1 _ ty2 -> go ty1 && go ty2 + HsOpTy _ ty1 tyop ty2 -> go tyop && go ty1 && go ty2 HsParTy _ ty -> go ty HsIParamTy _ _ ty -> go ty HsKindSig _ ty kind -> go ty && go kind ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1870,7 +1870,7 @@ cvtTypeKind typeOrKind ty let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y' in do { eq_tc <- returnLA eqTyCon_RDR - ; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) } + ; returnLA (mkHsOpTy NotPromoted px eq_tc py) } -- The long-term goal is to remove the above case entirely and -- subsume it under the case for InfixT. See #15815, comment:6, -- for more details. ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -806,13 +806,13 @@ data HsType pass , hst_ctxt :: LHsContext pass -- Context C => blah , hst_body :: LHsType pass } + -- | Type variable, type constructor, or (promoted) data constructor. + -- + -- Includes named wildcards (such as @_foo@), but not bare wildcards @_@. | HsTyVar (XTyVar pass) - PromotionFlag -- Whether explicitly promoted, - -- for the pretty printer - (LIdOccP pass) - -- Type variable, type constructor, or data constructor - -- see Note [Promotions (HsTyVar)] - -- See Note [Located RdrNames] in GHC.Hs.Expr + PromotionFlag -- ^ Whether explicitly promoted, for the pretty printer. + -- See Note [Promotions (HsTyVar)] + (LIdOccP pass) -- ^ See Note [Located RdrNames] in GHC.Hs.Expr | HsAppTy (XAppTy pass) (LHsType pass) @@ -838,9 +838,9 @@ data HsType pass [LHsType pass] -- Element types (length gives arity) | HsOpTy (XOpTy pass) - PromotionFlag -- Whether explicitly promoted, - -- for the pretty printer - (LHsType pass) (LIdOccP pass) (LHsType pass) + (LHsType pass) -- ^ First argument + (LHsType pass) -- ^ Operator (always a @HsTyVar@ or a @HsWildCardTy@) + (LHsType pass) -- ^ Second argument | HsParTy (XParTy pass) (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -388,7 +388,6 @@ [])) (HsOpTy (NoExtField) - (NotPromoted) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:11 }) @@ -411,12 +410,22 @@ (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:13 }) - (NameAnnTrailing + (AnnListItem []) (EpaComments [])) - (Exact - {Name: :})) + (HsTyVar + (NoEpTok) + (NotPromoted) + (L + (EpAnn + (EpaSpan { DumpParsedAst.hs:11:13 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Exact + {Name: :})))) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:15-16 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -335,7 +335,6 @@ [])) (HsOpTy (NoExtField) - (NotPromoted) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:11 }) @@ -360,14 +359,24 @@ (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:13 }) - (NameAnnTrailing + (AnnListItem []) (EpaComments [])) - (WithUserRdr - (Exact - {Name: :}) - {Name: :})) + (HsTyVar + (NoEpTok) + (NotPromoted) + (L + (EpAnn + (EpaSpan { DumpRenamedAst.hs:13:13 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (WithUserRdr + (Exact + {Name: :}) + {Name: :})))) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:15-16 }) ===================================== testsuite/tests/parser/should_fail/T17865.stderr ===================================== @@ -1,9 +1,8 @@ - -T17865.hs:3:11: error: [GHC-80236] +T17865.hs:3:10: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor MkT -T17865.hs:5:13: error: [GHC-80236] +T17865.hs:5:11: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor MkT' @@ -14,3 +13,4 @@ T17865.hs:7:16: error: [GHC-80236] T17865.hs:9:17: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor (:>$) + ===================================== testsuite/tests/partial-sigs/should_compile/T11107.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module T11107 where + +e :: Int `_` Bool +e = Left 0 \ No newline at end of file ===================================== testsuite/tests/partial-sigs/should_compile/T11107.stderr ===================================== @@ -0,0 +1,4 @@ +T11107.hs:4:10: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Either :: * -> * -> *’ + • In the type signature: e :: Int `_` Bool + ===================================== testsuite/tests/partial-sigs/should_compile/all.T ===================================== @@ -109,3 +109,4 @@ test('T22065', normal, compile, ['']) test('T16152', normal, compile, ['']) test('T20076', expect_broken(20076), compile, ['']) test('T26256', normal, compile, ['']) +test('T11107', normal, compile, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3969,11 +3969,11 @@ instance ExactPrint (HsType GhcPs) where tys' <- markAnnotated tys an1 <- markClosingParen an0 return (HsSumTy an1 tys') - exact (HsOpTy x promoted t1 lo t2) = do + exact (HsOpTy x t1 lo t2) = do t1' <- markAnnotated t1 lo' <- markAnnotated lo t2' <- markAnnotated t2 - return (HsOpTy x promoted t1' lo' t2') + return (HsOpTy x t1' lo' t2') exact (HsParTy (o,c) ty) = do o' <- markEpToken o ty' <- markAnnotated ty ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -102,7 +102,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 p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) (drop_lty 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 ===================================== utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs ===================================== @@ -1345,17 +1345,15 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode = hsep [ppr_mono_lty fun_ty unicode, atSign <> ppr_mono_lty arg_ki unicode] -ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode = - ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode + | Just pp_op <- ppr_infix_ty tyop + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise -- This shouldn't happen unless the user constructs weird ASTs via the GHC API + = let pp_op = ppr_mono_lty tyop unicode + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - char '\'' <> ppr_op - | otherwise = - ppr_op - ppr_op - | isSymOcc (getOccName op) = ppLDocName op - | otherwise = char '`' <> ppLDocName op <> char '`' + pp_ty1 = ppr_mono_lty ty1 unicode + pp_ty2 = ppr_mono_lty ty2 unicode ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) -- = ppr_mono_lty ty unicode @@ -1367,6 +1365,18 @@ ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _) unicode = starSymbol unicode ppr_mono_ty (XHsType HsRedacted{}) _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Maybe LaTeX +ppr_infix_ty (L _ (HsTyVar _ prom op)) = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = char '\'' <> pp_op + | otherwise = pp_op + pp_op + | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`") +ppr_infix_ty _ = Nothing + ppr_tylit :: HsLit DocNameI -> Bool -> LaTeX ppr_tylit (HsNatural _ n) _ = integer (il_value n) ppr_tylit (HsString _ s) _ = text (show s) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -1863,15 +1863,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ = [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign <> ppr_mono_lty arg_ki 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 +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode qual _ + | Just pp_op <- ppr_infix_ty tyop qual + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise -- This shouldn't happen unless the user constructs weird ASTs via the GHC API + = let pp_op = ppr_mono_lty tyop unicode qual HideEmptyContexts + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - promoQuote ppr_op - | otherwise = - ppr_op - ppr_op = ppLDocName qual Infix op + pp_ty1 = ppr_mono_lty ty1 unicode qual HideEmptyContexts + pp_ty2 = ppr_mono_lty ty2 unicode qual HideEmptyContexts ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts) -- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) @@ -1882,6 +1882,16 @@ ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_mono_ty (XHsType HsRedacted{}) _ _ _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Qualification -> Maybe Html +ppr_infix_ty (L _ (HsTyVar _ prom op)) qual = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = promoQuote pp_op + | otherwise = pp_op + pp_op = ppLDocName qual Infix op +ppr_infix_ty (L _ (HsWildCardTy _)) _ = Just (toHtml ("`_`" :: LText)) +ppr_infix_ty _ _ = Nothing + ppr_tylit :: HsLit DocNameI -> Html ppr_tylit (HsNatural _ n) = toHtml (show (il_value n)) ppr_tylit (HsString _ s) = toHtml (show s) ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -842,7 +842,8 @@ synifyType _ boundTvs (TyConApp tc tys) = | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise -> - noLocA $ HsOpTy noExtField IsPromoted hTy (noLocA $ noUserRdr $ getName tc) tTy + let tyop = noLocA $ HsTyVar noAnn IsPromoted (noLocA $ noUserRdr $ getName tc) + in noLocA $ HsOpTy noExtField hTy tyop tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -854,9 +855,8 @@ synifyType _ boundTvs (TyConApp tc tys) = noLocA $ HsOpTy noExtField - NotPromoted (synifyType WithinType boundTvs ty1) - (noLocA $ noUserRdr eqTyConName) + (noLocA $ HsTyVar noAnn NotPromoted (noLocA $ noUserRdr eqTyConName)) (synifyType WithinType boundTvs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) @@ -864,9 +864,8 @@ synifyType _ boundTvs (TyConApp tc tys) = mk_app_tys ( HsOpTy noExtField - prom (synifyType WithinType boundTvs ty1) - (noLocA $ noUserRdr $ getName tc) + (noLocA $ HsTyVar noAnn prom (noLocA $ noUserRdr $ getName tc)) (synifyType WithinType boundTvs ty2) ) tys_rest ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -465,8 +465,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 prom ty1 op ty2) = - paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2) + go p (HsOpTy x ty1 op ty2) = + paren p PREC_FUN $ HsOpTy x (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 ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -399,11 +399,11 @@ renameType t = case t of return (HsAppTy noAnn lhs rhs) HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy _ prom a (L loc op) b -> do - op' <- renameName (getName op) + HsOpTy _ a op b -> do + op' <- renameLType op a' <- renameLType a b' <- renameLType b - return (HsOpTy noAnn prom a' (L loc op') b') + return (HsOpTy noAnn a' op' b') HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty ===================================== utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs ===================================== @@ -104,8 +104,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsMultAnn w <*> renameLType 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 f la lop lb) = - HsOpTy x <$> pure f <*> renameLType la <*> renameLNameOcc lop <*> renameLType lb +renameType (HsOpTy x la lop lb) = + HsOpTy x <$> renameLType la <*> renameLType 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9831385bbdcbf43665b62212233e8110... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9831385bbdcbf43665b62212233e8110... You're receiving this email because of your account on gitlab.haskell.org.