Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

30 changed files:

Changes:

  • compiler/GHC/Hs/Type.hs
    ... ... @@ -683,11 +683,12 @@ ignoreParens ty = ty
    683 683 
     mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs
    684 684 
     mkAnonWildCardTy tok = HsWildCardTy tok
    685 685
    686 
    -mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)
    686 
    +mkHsOpTy :: (Anno (IdOccGhcP p) ~ EpAnn a)
    687 687 
              => PromotionFlag
    688 
    -         -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p))
    688 
    +         -> LHsType (GhcPass p) -> LIdOccP (GhcPass p)
    689 689 
              -> LHsType (GhcPass p) -> HsType (GhcPass p)
    690 
    -mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2
    690 
    +mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField ty1 tyop ty2
    691 
    +  where tyop = L (l2l op) $ HsTyVar noAnn prom op
    691 692
    692 693 
     mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
    693 694 
     mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2)
    ... ... @@ -745,7 +746,7 @@ hsTyGetAppHead_maybe = go
    745 746 
         go (L _ (HsTyVar _ _ ln))    = Just ln
    746 747 
         go (L _ (HsAppTy _ l _))     = go l
    747 748 
         go (L _ (HsAppKindTy _ t _)) = go t
    748 
    -    go (L _ (HsOpTy _ _ _ ln _)) = Just ln
    749 
    +    go (L _ (HsOpTy _ _ op _))   = go op
    749 750 
         go (L _ (HsParTy _ t))       = go t
    750 751 
         go (L _ (HsKindSig _ t _))   = go t
    751 752 
         go _                         = Nothing
    ... ... @@ -1457,9 +1458,14 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
    1457 1458 
       = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
    1458 1459 
     ppr_mono_ty (HsAppKindTy _ ty k)
    1459 1460 
       = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k
    1460 
    -ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)
    1461 
    -  = sep [ ppr_mono_lty ty1
    1462 
    -        , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ]
    1461 
    +ppr_mono_ty (HsOpTy _ ty1 tyop ty2)
    1462 
    +  | Just pp_op <- ppr_infix_ty tyop
    1463 
    +  = sep [pp_ty1, sep [pp_op, pp_ty2]]
    1464 
    +  | otherwise  -- This shouldn't happen unless the user constructs weird ASTs via the GHC API
    1465 
    +  = hang (ppr tyop) 2 (sep [pp_ty1, pp_ty2])
    1466 
    +  where
    1467 
    +    pp_ty1 = ppr_mono_lty ty1
    1468 
    +    pp_ty2 = ppr_mono_lty ty2
    1463 1469 
     ppr_mono_ty (HsParTy _ ty)
    1464 1470 
       = parens (ppr_mono_lty ty)
    1465 1471 
       -- Put the parens in where the user did
    ... ... @@ -1476,6 +1482,11 @@ ppr_mono_ty (XHsType t) = case ghcPass @p of
    1476 1482 
         HsRecTy _ flds  -> pprHsConDeclRecFields flds
    1477 1483 
       GhcRn -> ppr t
    1478 1484
    1485 
    +ppr_infix_ty :: (OutputableBndrId p) => LHsType (GhcPass p) -> Maybe SDoc
    1486 
    +ppr_infix_ty (L _ (HsTyVar _ prom (L _ op))) = Just (pprOccWithTick Infix prom op)
    1487 
    +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`")
    1488 
    +ppr_infix_ty _ = Nothing
    1489 
    +
    1479 1490 
     --------------------------
    1480 1491 
     ppr_fun_ty :: (OutputableBndrId p)
    1481 1492 
                => 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
    632 632 
     nlHsTyConApp prom fixity tycon tys
    633 633 
       | Infix <- fixity
    634 634 
       , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys
    635 
    -  = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest
    635 
    +  = foldl' mk_app (noLocA $ mkHsOpTy prom ty1 (noLocA tycon) ty2) rest
    636 636 
       | otherwise
    637 637 
       = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys
    638 638 
       where

  • compiler/GHC/HsToCore/Quote.hs
    ... ... @@ -1473,8 +1473,7 @@ repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
    1473 1473 
     repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
    1474 1474 
                                      tcon <- repUnboxedSumTyCon (length tys)
    1475 1475 
                                      repTapps tcon tys1
    1476 
    -repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1)
    1477 
    -                                   `nlHsAppTy` ty2)
    1476 
    +repTy (HsOpTy _ ty1 op ty2) = repLTy ((op `nlHsAppTy` ty1) `nlHsAppTy` ty2)
    1478 1477 
     repTy (HsParTy _ t)         = repLTy t
    1479 1478 
     repTy (HsStarTy _)          = repTStar
    1480 1479 
     repTy (HsKindSig _ t k)     = do

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -1922,9 +1922,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where
    1922 1922 
           HsSumTy _ tys ->
    1923 1923 
             [ toHie tys
    1924 1924 
             ]
    1925 
    -      HsOpTy _ _prom a op b ->
    1925 
    +      HsOpTy _ a op b ->
    1926 1926 
             [ toHie a
    1927 
    -        , toHie $ C Use op
    1927 
    +        , toHie op
    1928 1928 
             , toHie b
    1929 1929 
             ]
    1930 1930 
           HsParTy _ a ->

  • compiler/GHC/Parser.y
    ... ... @@ -2316,15 +2316,14 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
    2316 2316 
             : ftype %shift                  { $1 }
    2317 2317 
             | ftype tyop infixtype          { $1 >>= \ $1 ->
    2318 2318 
                                               $3 >>= \ $3 ->
    2319 
    -                                          do { let (op, prom) = $2
    2320 
    -                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)
    2321 
    -                                             ; mkHsOpTyPV prom $1 op $3 } }
    2319 
    +                                          do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)
    2320 
    +                                             ; mkHsOpTyPV $1 $2 $3 } }
    2322 2321 
             | unpackedness infixtype        { $2 >>= \ $2 ->
    2323 2322 
                                               mkUnpackednessPV $1 $2 }
    2324 2323
    2325 2324 
     ftype :: { forall b. DisambTD b => PV (LocatedA b) }
    2326 2325 
             : atype                         { mkHsAppTyHeadPV $1 }
    2327 
    -        | tyop                          { failOpFewArgs (fst $1) }
    2326 
    +        | tyop                          { failOpFewArgs $1 }
    2328 2327 
             | ftype tyarg                   { $1 >>= \ $1 ->
    2329 2328 
                                               mkHsAppTyPV $1 $2 }
    2330 2329 
             | ftype PREFIX_AT atype         { $1 >>= \ $1 ->
    ... ... @@ -2334,15 +2333,12 @@ tyarg :: { LHsType GhcPs }
    2334 2333 
             : atype                         { $1 }
    2335 2334 
             | unpackedness atype            {% addUnpackednessP $1 $2 }
    2336 2335
    2337 
    -tyop :: { (LocatedN RdrName, PromotionFlag) }
    2338 
    -        : qtyconop                      { ($1, NotPromoted) }
    2339 
    -        | tyvarop                       { ($1, NotPromoted) }
    2340 
    -        | SIMPLEQUOTE qconop            {% do { op <- amsr (sLL $1 $> (unLoc $2))
    2341 
    -                                                           (NameAnnQuote (epTok $1) (gl $2) [])
    2342 
    -                                              ; return (op, IsPromoted) } }
    2343 
    -        | SIMPLEQUOTE varop             {% do { op <- amsr (sLL $1 $> (unLoc $2))
    2344 
    -                                                           (NameAnnQuote (epTok $1) (gl $2) [])
    2345 
    -                                              ; return (op, IsPromoted) } }
    2336 
    +tyop :: { LHsType GhcPs }
    2337 
    +        : qtyconop                      { sL1a $1 (HsTyVar noAnn NotPromoted $1) }
    2338 
    +        | tyvarop                       { sL1a $1 (HsTyVar noAnn NotPromoted $1) }
    2339 
    +        | SIMPLEQUOTE qconop            { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) }
    2340 
    +        | SIMPLEQUOTE varop             { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) }
    2341 
    +        | '`' '_' '`'                   { sLLa $1 $> (mkAnonWildCardTy (epTok $2)) }   -- TODO: reuse hole_op (blocked on #27111)
    2346 2342
    2347 2343 
     atype :: { LHsType GhcPs }
    2348 2344 
             : ntgtycon                       {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) }      -- Not including unit tuples
    ... ... @@ -4475,12 +4471,12 @@ hintLinear span = do
    4475 4471 
       unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction
    4476 4472
    4477 4473 
     -- Does this look like (a %m)?
    4478 
    -looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool
    4479 
    -looksLikeMult ty1 l_op ty2
    4480 
    -  | Unqual op_name <- unLoc l_op
    4474 
    +looksLikeMult :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> Bool
    4475 
    +looksLikeMult ty1 tyop ty2
    4476 
    +  | HsTyVar _ _ (L _ (Unqual op_name)) <- unLoc tyop
    4481 4477 
       , occNameFS op_name == fsLit "%"
    4482 4478 
       , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)
    4483 
    -  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)
    4479 
    +  , Strict.Just pct_pos <- getBufSpan (getLocA tyop)
    4484 4480 
       , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)
    4485 4481 
       , bufSpanEnd ty1_pos /= bufSpanStart pct_pos
    4486 4482 
       , bufSpanEnd pct_pos == bufSpanStart ty2_pos

  • compiler/GHC/Parser/PostProcess.hs
    ... ... @@ -1140,8 +1140,8 @@ checkTyClHdr is_cls ty
    1140 1140
    1141 1141 
         go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
    1142 1142 
           | isRdrTc tc               = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l)
    1143 
    -    go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
    1144 
    -      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l)
    1143 
    +    go cs l (HsOpTy _ t1 tyop t2) acc ops cps _fix
    1144 
    +      = goL (cs Semi.<> comments l) tyop (lhs:rhs:acc) ops cps Infix
    1145 1145 
           where lhs = HsValArg noExtField t1
    1146 1146 
                 rhs = HsValArg noExtField t2
    1147 1147 
         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
    2409 2409 
       -- | Disambiguate @f \@t@ (visible kind application)
    2410 2410 
       mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
    2411 2411 
       -- | Disambiguate @f \# x@ (infix operator)
    2412 
    -  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
    2412 
    +  mkHsOpTyPV :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> PV (LocatedA b)
    2413 2413 
       -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
    2414 2414 
       mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)
    2415 2415
    ... ... @@ -2417,8 +2417,8 @@ instance DisambTD (HsType GhcPs) where
    2417 2417 
       mkHsAppTyHeadPV = return
    2418 2418 
       mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
    2419 2419 
       mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
    2420 
    -  mkHsOpTyPV prom t1 op t2 = do
    2421 
    -    let (L l ty) = mkLHsOpTy prom t1 op t2
    2420 
    +  mkHsOpTyPV t1 tyop t2 = do
    2421 
    +    let (L l ty) = mkLHsOpTy t1 tyop t2
    2422 2422 
         !cs <- getCommentsFor (locA l)
    2423 2423 
         return (L (addCommentsToEpAnn l cs) ty)
    2424 2424 
       mkUnpackednessPV = addUnpackednessP
    ... ... @@ -2460,11 +2460,11 @@ instance DisambTD DataConBuilder where
    2460 2460 
         addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $
    2461 2461 
                           (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
    2462 2462
    2463 
    -  mkHsOpTyPV prom lhs tc rhs = do
    2463 
    +  mkHsOpTyPV lhs op@(L _ (HsTyVar _ prom tc)) rhs = do
    2464 2464 
           check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
    2465 2465 
           data_con <- eitherToP $ tyConToDataCon tc
    2466 2466 
           !cs <- getCommentsFor (locA l)
    2467 
    -      checkNotPromotedDataCon prom data_con
    2467 
    +      checkNotPromotedDataCon (getLocA op) prom data_con
    2468 2468 
           return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
    2469 2469 
         where
    2470 2470 
           l = combineLocsA lhs rhs
    ... ... @@ -2473,6 +2473,9 @@ instance DisambTD DataConBuilder where
    2473 2473 
             addError $ mkPlainErrorMsgEnvelope (locA l) $
    2474 2474 
                          (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))
    2475 2475 
           check_no_ops _ = return ()
    2476 
    +  mkHsOpTyPV _ (L l (HsWildCardTy _)) _ =
    2477 
    +    addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole
    2478 
    +  mkHsOpTyPV _ op _ = pprPanic "mkHsOpTyPV: impossible type operator" (ppr op)
    2476 2479
    2477 2480 
       mkUnpackednessPV unpk constr_stuff
    2478 2481 
         | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff
    ... ... @@ -2488,7 +2491,7 @@ instance DisambTD DataConBuilder where
    2488 2491 
     tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
    2489 2492 
     tyToDataConBuilder (L l (HsTyVar _ prom v)) = do
    2490 2493 
       data_con <- eitherToP $ tyConToDataCon v
    2491 
    -  checkNotPromotedDataCon prom data_con
    2494 
    +  checkNotPromotedDataCon (locA l) prom data_con
    2492 2495 
       return $ L l (PrefixDataConBuilder nilOL data_con)
    2493 2496 
     tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
    2494 2497 
       let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))
    ... ... @@ -2501,10 +2504,14 @@ tyToDataConBuilder t =
    2501 2504 
                         (PsErrInvalidDataCon (unLoc t))
    2502 2505
    2503 2506 
     -- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).
    2504 
    -checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()
    2505 
    -checkNotPromotedDataCon NotPromoted _ = return ()
    2506 
    -checkNotPromotedDataCon IsPromoted (L l name) =
    2507 
    -  addError $ mkPlainErrorMsgEnvelope (locA l) $
    2507 
    +checkNotPromotedDataCon
    2508 
    +  :: SrcSpan          -- ^ The enclosing SrcSpan containing the tick
    2509 
    +  -> PromotionFlag
    2510 
    +  -> LocatedN RdrName
    2511 
    +  -> PV ()
    2512 
    +checkNotPromotedDataCon _   NotPromoted _ = return ()
    2513 
    +checkNotPromotedDataCon loc IsPromoted (L _ name) =
    2514 
    +  addError $ mkPlainErrorMsgEnvelope loc $
    2508 2515 
         PsErrIllegalPromotionQuoteDataCon name
    2509 2516
    2510 2517 
     mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
    ... ... @@ -3460,12 +3467,15 @@ failSpliceOrQuoteTwice lvl =
    3460 3467 
     warnStarIsType :: MonadP m => SrcSpan -> m ()
    3461 3468 
     warnStarIsType span = addPsMessage span PsWarnStarIsType
    3462 3469
    3463 
    -failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
    3464 
    -failOpFewArgs (L loc op) =
    3470 
    +failOpFewArgs :: MonadP m => LHsType GhcPs -> m a
    3471 
    +failOpFewArgs (L _ (HsTyVar _ _ (L loc op))) =
    3465 3472 
       do { star_is_type <- getBit StarIsTypeBit
    3466 3473 
          ; let is_star_type = if star_is_type then StarIsType else StarIsNotType
    3467 3474 
          ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
    3468 3475 
              (PsErrOpFewArgs is_star_type op) }
    3476 
    +failOpFewArgs (L l (HsWildCardTy _)) =
    3477 
    +  addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole
    3478 
    +failOpFewArgs op = pprPanic "failOpFewArgs: impossible type operator" (ppr op)
    3469 3479
    3470 3480 
     requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m ()
    3471 3481 
     requireExplicitNamespaces kw = do
    ... ... @@ -3701,10 +3711,10 @@ mkSumOrTuplePat l Boxed a@Sum{} _ =
    3701 3711 
         addFatalError $
    3702 3712 
           mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
    3703 3713
    3704 
    -mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
    3705 
    -mkLHsOpTy prom x op y =
    3714 
    +mkLHsOpTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
    3715 
    +mkLHsOpTy x op y =
    3706 3716 
       let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
    3707 
    -  in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
    3717 
    +  in L (noAnnSrcSpan loc) (HsOpTy noExtField x op y)
    3708 3718
    3709 3719 
     mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs
    3710 3720 
     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 )
    50 50
    51 51 
     import GHC.Types.Basic (TypeOrKind (TypeLevel))
    52 52 
     import GHC.Types.FieldLabel
    53 
    -import GHC.Types.Fixity
    54 53 
     import GHC.Types.Id.Make
    55 54 
     import GHC.Types.Name
    56 55 
     import GHC.Types.Name.Set
    ... ... @@ -401,12 +400,7 @@ rnExpr (OpApp _ e1 op e2)
    401 400 
             -- we used to avoid fixity stuff, but we can't easily tell any
    402 401 
             -- more, so I've removed the test.  Adding HsPars in GHC.Tc.Deriv.Generate
    403 402 
             -- should prevent bad things happening.
    404 
    -        ; fixity <- case op' of
    405 
    -              L _ (HsVar _ (L _ (WithUserRdr _ n))) -> lookupFixityRn n
    406 
    -              L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f
    407 
    -              _ -> return (Fixity minPrecedence InfixL)
    408 
    -                   -- c.f. lookupFixity for unbound
    409 
    -
    403 
    +        ; fixity <- lookupExprFixityRn op'
    410 404 
             ; lexical_negation <- xoptM LangExt.LexicalNegation
    411 405 
             ; let negation_handling | lexical_negation = KeepNegationIntact
    412 406 
                                     | otherwise = ReassociateNegation

  • compiler/GHC/Rename/Fixity.hs
    ... ... @@ -11,7 +11,8 @@ module GHC.Rename.Fixity
    11 11 
        , lookupFixityRn
    12 12 
        , lookupFixityRn_help
    13 13 
        , lookupFieldFixityRn
    14 
    -   , lookupTyFixityRn
    14 
    +   , lookupExprFixityRn
    15 
    +   , lookupTypeFixityRn
    15 16 
        ) where
    16 17
    17 18 
     import GHC.Prelude
    ... ... @@ -26,6 +27,7 @@ import GHC.Unit.Module.ModIface
    26 27 
     import GHC.Types.Fixity.Env
    27 28 
     import GHC.Types.Name
    28 29 
     import GHC.Types.Name.Env
    30 
    +import GHC.Types.Name.Reader
    29 31 
     import GHC.Types.Fixity
    30 32 
     import GHC.Types.SrcLoc
    31 33
    ... ... @@ -198,8 +200,19 @@ lookupFixityRn_help name
    198 200 
         doc = text "Checking fixity for" <+> ppr name
    199 201
    200 202 
     ---------------
    201 
    -lookupTyFixityRn :: LocatedN Name -> RnM Fixity
    202 
    -lookupTyFixityRn = lookupFixityRn . unLoc
    203 
    -
    204 203 
     lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
    205 204 
     lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n)
    205 
    +
    206 
    +lookupExprFixityRn :: LHsExpr GhcRn -> RnM Fixity
    207 
    +lookupExprFixityRn e =
    208 
    +  case e of
    209 
    +    L _ (HsVar _ op) -> lookupFixityRn (unLocWithUserRdr op)
    210 
    +    L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f
    211 
    +    _ -> return (Fixity minPrecedence InfixL)
    212 
    +    -- c.f. lookupFixity for unbound
    213 
    +
    214 
    +lookupTypeFixityRn :: LHsType GhcRn -> RnM Fixity
    215 
    +lookupTypeFixityRn t =
    216 
    +  case t of
    217 
    +    L _ (HsTyVar _ _ op) -> lookupFixityRn (unLocWithUserRdr op)
    218 
    +    _ -> return (Fixity minPrecedence InfixL)

  • compiler/GHC/Rename/HsType.hs
    ... ... @@ -54,7 +54,7 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV
    54 54 
                              , typeAppErr, newLocalBndrRn, checkDupRdrNames
    55 55 
                              , checkShadowedRdrNames )
    56 56 
     import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
    57 
    -                         , lookupTyFixityRn )
    57 
    +                         , lookupTypeFixityRn )
    58 58 
     import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
    59 59 
     import GHC.Tc.Errors.Types
    60 60 
     import GHC.Tc.Errors.Ppr ( pprHsDocContext )
    ... ... @@ -67,7 +67,6 @@ import GHC.Types.Name
    67 67 
     import GHC.Types.SrcLoc
    68 68 
     import GHC.Types.Name.Set
    69 69 
     import GHC.Types.FieldLabel
    70 
    -import GHC.Types.Error
    71 70
    72 71 
     import GHC.Utils.Misc
    73 72 
     import GHC.Types.Fixity ( compareFixity, negateFixity )
    ... ... @@ -551,16 +550,13 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
    551 550 
            ; checkPromotedDataConName env tv Prefix ip name
    552 551 
            ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFV name) }
    553 552
    554 
    -rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
    555 
    -  = setSrcSpan (getLocA l_op) $
    556 
    -    do  { let op_rdr = unLoc l_op
    557 
    -        ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
    558 
    -        ; let op_name = unLoc l_op'
    559 
    -        ; fix   <- lookupTyFixityRn l_op'
    553 
    +rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2)
    554 
    +  = setSrcSpan (getLocA tyop) $
    555 
    +    do  { (tyop', fvs1) <- rnHsTyOp env ty tyop
    556 
    +        ; fix <- lookupTypeFixityRn tyop'
    560 557 
             ; (ty1', fvs2) <- rnLHsTyKi env ty1
    561 558 
             ; (ty2', fvs3) <- rnLHsTyKi env ty2
    562 
    -        ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2'
    563 
    -        ; checkPromotedDataConName env ty Infix prom op_name
    559 
    +        ; res_ty <- mkHsOpTyRn tyop' fix ty1' ty2'
    564 560 
             ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
    565 561
    566 562 
     rnHsTyKi env (HsParTy _ ty)
    ... ... @@ -770,15 +766,20 @@ rnLTyVar (L loc rdr_name)
    770 766 
            ; return (L loc tyvar) }
    771 767
    772 768 
     --------------
    773 
    -rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName
    774 
    -         -> RnM (LocatedN Name, FreeVars)
    775 
    -rnHsTyOp env overall_ty (L loc op)
    769 
    +rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs
    770 
    +         -> RnM (LHsType GhcRn, FreeVars)
    771 
    +rnHsTyOp env overall_ty tyop
    772 
    +  | L l (HsTyVar ann prom (L loc op)) <- tyop
    776 773 
       = do { op' <- rnTyVar env op
    777 774 
            ; unlessXOptM LangExt.TypeOperators $
    778 775 
                if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
    779 776 
                then addDiagnostic TcRnTypeEqualityRequiresOperators
    780 
    -           else addErr $ TcRnIllegalTypeOperator overall_ty op
    781 
    -       ; return (L loc op', unitFV op') }
    777 
    +           else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op
    778 
    +       ; checkPromotedDataConName env overall_ty Infix prom op'
    779 
    +       ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op')))
    780 
    +       ; return (tyop', unitFV op') }
    781 
    +  | otherwise
    782 
    +  = rnLHsTyKi env tyop
    782 783
    783 784 
     --------------
    784 785 
     checkWildCard :: RnTyKiEnv
    ... ... @@ -1400,33 +1401,33 @@ precedence and does not require rearrangement.
    1400 1401
    1401 1402 
     ---------------
    1402 1403 
     -- Building (ty1 `op1` (ty2a `op2` ty2b))
    1403 
    -mkHsOpTyRn :: PromotionFlag
    1404 
    -           -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn
    1404 
    +mkHsOpTyRn :: LHsType GhcRn
    1405 
    +           -> Fixity -> LHsType GhcRn -> LHsType GhcRn
    1405 1406 
                -> RnM (HsType GhcRn)
    1406 1407
    1407 
    -mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))
    1408 
    -  = do  { fix2 <- lookupTyFixityRn (fmap getName op2)
    1409 
    -        ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }
    1408 
    +mkHsOpTyRn tyop1 fix1 ty1 (L loc2 (HsOpTy _ ty2a tyop2 ty2b))
    1409 
    +  = do  { fix2 <- lookupTypeFixityRn tyop2
    1410 
    +        ; mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2 }
    1410 1411
    1411 
    -mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangement
    1412 
    -  = return (HsOpTy noExtField prom1 ty1 op1 ty2)
    1412 
    +mkHsOpTyRn tyop _ ty1 ty2              -- Default case, no rearrangement
    1413 
    +  = return (HsOpTy noExtField ty1 tyop ty2)
    1413 1414
    1414 1415 
     ---------------
    1415 
    -mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn
    1416 
    -            -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn
    1416 
    +mk_hs_op_ty :: LHsType GhcRn -> Fixity -> LHsType GhcRn
    1417 
    +            -> LHsType GhcRn -> Fixity -> LHsType GhcRn
    1417 1418 
                 -> LHsType GhcRn -> SrcSpanAnnA
    1418 1419 
                 -> RnM (HsType GhcRn)
    1419 
    -mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2
    1420 
    -  | nofix_error     = do { precParseErr (NormalOp (unLoc op1),fix1)
    1421 
    -                                        (NormalOp (unLoc op2),fix2)
    1420 
    +mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2
    1421 
    +  | nofix_error     = do { precParseErr (get_tyop tyop1,fix1)
    1422 
    +                                        (get_tyop tyop2,fix2)
    1422 1423 
                              ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }
    1423 1424 
       | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))
    1424 1425 
       | otherwise       = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)
    1425 
    -                           new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a
    1426 
    +                           new_ty <- mkHsOpTyRn tyop1 fix1 ty1 ty2a
    1426 1427 
                              ; return (noLocA new_ty `op2ty` ty2b) }
    1427 1428 
       where
    1428 
    -    lhs `op1ty` rhs = HsOpTy noExtField prom1 lhs op1 rhs
    1429 
    -    lhs `op2ty` rhs = HsOpTy noExtField prom2 lhs op2 rhs
    1429 
    +    lhs `op1ty` rhs = HsOpTy noExtField lhs tyop1 rhs
    1430 
    +    lhs `op2ty` rhs = HsOpTy noExtField lhs tyop2 rhs
    1430 1431 
         (nofix_error, associate_right) = compareFixity fix1 fix2
    1431 1432
    1432 1433
    ... ... @@ -1493,6 +1494,11 @@ get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv
    1493 1494 
     get_op (L _ (XExpr (HsRecSelRn fld)))    = RecFldOp fld
    1494 1495 
     get_op other                             = pprPanic "get_op" (ppr other)
    1495 1496
    1497 
    +get_tyop :: LHsType GhcRn -> OpName
    1498 
    +get_tyop (L _ (HsTyVar _ _ n))  = NormalOp (unLoc n)
    1499 
    +get_tyop (L _ (HsWildCardTy _)) = UnboundOp (Unqual (mkVarOcc "_"))
    1500 
    +get_tyop other                  = pprPanic "get_tyop" (ppr other)
    1501 
    +
    1496 1502 
     -- Parser left-associates everything, but
    1497 1503 
     -- derived instances may have correctly-associated things to
    1498 1504 
     -- in the right operand.  So we just check that the right operand is OK
    ... ... @@ -2119,8 +2125,8 @@ extract_lty (L _ ty) acc
    2119 2125 
                                          extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables]
    2120 2126 
                                          extract_lty ty2 acc
    2121 2127 
           HsIParamTy _ _ ty           -> extract_lty ty acc
    2122 
    -      HsOpTy _ _ ty1 tv ty2       -> extract_lty ty1 $
    2123 
    -                                     extract_tv tv $
    2128 
    +      HsOpTy _ ty1 op ty2         -> extract_lty ty1 $
    2129 
    +                                     extract_lty op $
    2124 2130 
                                          extract_lty ty2 acc
    2125 2131 
           HsParTy _ ty                -> extract_lty ty acc
    2126 2132 
           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
    1314 1314 
           name <- lookupTypeOccTPRnM rdr
    1315 1315 
           pure (L l $ WithUserRdr rdr name)
    1316 1316
    1317 
    +rn_tyop_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn)
    1318 
    +rn_tyop_pat tyop
    1319 
    +  | L l (HsTyVar ann prom l_op) <- tyop
    1320 
    +  = do l_op' <- rn_ty_pat_var l_op
    1321 
    +       let op_name = getName l_op'
    1322 
    +       when (isDataConName op_name && not (isPromoted prom)) $
    1323 
    +         liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
    1324 
    +       return (L l $ HsTyVar ann prom l_op')
    1325 
    +  | otherwise = rn_lty_pat tyop
    1326 
    +
    1317 1327 
     -- | Rename type patterns
    1318 1328 
     --
    1319 1329 
     -- For the difference between `rn_ty_pat` and `rnHsTyKi` see Note [CpsRn monad]
    ... ... @@ -1373,15 +1383,13 @@ rn_ty_pat (HsSumTy an tys) = do
    1373 1383 
       tys' <- mapM rn_lty_pat tys
    1374 1384 
       pure (HsSumTy an tys')
    1375 1385
    1376 
    -rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do
    1386 
    +rn_ty_pat (HsOpTy _ ty1 tyop ty2) = do
    1377 1387 
       ty1' <- rn_lty_pat ty1
    1378 
    -  l_op' <- rn_ty_pat_var l_op
    1388 
    +  tyop' <- rn_tyop_pat tyop
    1379 1389 
       ty2' <- rn_lty_pat ty2
    1380 
    -  fix  <- liftRn $ lookupTyFixityRn $ fmap getName l_op'
    1381 
    -  let op_name = getName l_op'
    1382 
    -  when (isDataConName op_name && not (isPromoted prom)) $
    1383 
    -    liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
    1384 
    -  liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2'
    1390 
    +  liftRn $ do
    1391 
    +    fix <- lookupTypeFixityRn tyop'
    1392 
    +    mkHsOpTyRn tyop' fix ty1' ty2'
    1385 1393
    1386 1394 
     rn_ty_pat (HsParTy an ty) = do
    1387 1395 
       ty' <- rn_lty_pat ty

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -1136,15 +1136,11 @@ expr_to_type earg =
    1136 1136 
           do { lhs' <- go lhs
    1137 1137 
              ; rhs' <- unwrap_wc rhs
    1138 1138 
              ; return (L l (HsAppKindTy noExtField lhs' rhs')) }
    1139 
    -    go (L l e@(OpApp _ lhs op rhs)) =
    1139 
    +    go (L l (OpApp _ lhs op rhs)) =
    1140 1140 
           do { lhs' <- go lhs
    1141 1141 
              ; op'  <- go op
    1142 1142 
              ; rhs' <- go rhs
    1143 
    -         ; op_id <- unwrap_op_tv op'
    1144 
    -         ; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) }
    1145 
    -      where
    1146 
    -        unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id
    1147 
    -        unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)
    1143 
    +         ; return (L l (HsOpTy noExtField lhs' op' rhs')) }
    1148 1144 
         go (L l (HsOverLit _ ol))
    1149 1145 
           = do { let lit = tyLitFromOverloadedLit (ol_val ol)
    1150 1146 
                ; return (L l (HsTyLit noExtField lit)) }

  • compiler/GHC/Tc/Gen/HsType.hs
    ... ... @@ -103,7 +103,7 @@ import GHC.Core.TyCo.Ppr
    103 103 
     import GHC.Builtin.Types.Prim
    104 104 
     import GHC.Types.Error
    105 105 
     import GHC.Types.Name.Env
    106 
    -import GHC.Types.Name.Reader( WithUserRdr(..), lookupLocalRdrOcc )
    106 
    +import GHC.Types.Name.Reader
    107 107 
     import GHC.Types.Var
    108 108 
     import GHC.Types.Var.Set
    109 109 
     import GHC.Core.TyCon
    ... ... @@ -1146,8 +1146,9 @@ tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: inva
    1146 1146 
     tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind
    1147 1147 
       = tc_fun_type mode mult ty1 ty2 exp_kind
    1148 1148
    1149 
    -tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind
    1150 
    -  | op `hasKey` unrestrictedFunTyConKey
    1149 
    +tcHsType mode (HsOpTy _ ty1 tyop ty2) exp_kind
    1150 
    +  | L _ (HsTyVar _ _ op) <- tyop
    1151 
    +  , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey
    1151 1152 
       = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind
    1152 1153
    1153 1154 
     --------- Foralls
    ... ... @@ -1531,12 +1532,15 @@ splitHsAppTys_maybe hs_ty
    1531 1532 
         is_app :: HsType GhcRn -> Bool
    1532 1533 
         is_app (HsAppKindTy {})        = True
    1533 1534 
         is_app (HsAppTy {})            = True
    1534 
    -    is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _)
    1535 
    -      = not (op `hasKey` unrestrictedFunTyConKey)
    1535 
    +    is_app (HsOpTy _ _ tyop _)
    1536 
    +      | L _ (HsTyVar _ _ op) <- tyop
    1537 
    +      , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey
    1536 1538 
           -- I'm not sure why this funTyConKey test is necessary
    1537 1539 
           -- Can it even happen?  Perhaps for   t1 `(->)` t2
    1538 1540 
           -- but then maybe it's ok to treat that like a normal
    1539 1541 
           -- application rather than using the special rule for HsFunTy
    1542 
    +      = False
    1543 
    +    is_app (HsOpTy {})             = True
    1540 1544 
         is_app (HsTyVar {})            = True
    1541 1545 
         is_app (HsParTy _ (L _ ty))    = is_app ty
    1542 1546 
         is_app _                       = False
    ... ... @@ -1552,9 +1556,8 @@ splitHsAppTys hs_ty = go (noLocA hs_ty) []
    1552 1556 
         go (L _  (HsAppTy _ f a))      as = go f (HsValArg noExtField a : as)
    1553 1557 
         go (L _  (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as)
    1554 1558 
         go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)
    1555 
    -    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as
    1556 
    -      = ( L (l2l sp) (HsTyVar noAnn prom op)
    1557 
    -        , HsValArg noExtField l : HsValArg noExtField r : as )
    1559 
    +    go (L _  (HsOpTy _ l tyop r))  as =
    1560 
    +      (tyop, HsValArg noExtField l : HsValArg noExtField r : as)
    1558 1561 
         go f as = (f, as)
    1559 1562
    1560 1563 
     ---------------------------

  • compiler/GHC/Tc/Gen/Pat.hs
    ... ... @@ -549,7 +549,7 @@ pat_to_type (NPat _ (L _ ol) _ _)
    549 549 
     pat_to_type (ConPat _ lname (InfixCon left right))
    550 550 
       = do { lty <- pat_to_type (unLoc left)
    551 551 
            ; rty <- pat_to_type (unLoc right)
    552 
    -       ; let { t = noLocA (HsOpTy noExtField NotPromoted lty lname rty)}
    552 
    +       ; let { t = noLocA (mkHsOpTy NotPromoted lty lname rty)}
    553 553 
            ; pure t }
    554 554 
     pat_to_type (ConPat _ lname (PrefixCon args))
    555 555 
       = 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
    292 292 
           HsListTy _ ty                  -> go ty
    293 293 
           HsTupleTy _ _ tys              -> gos tys
    294 294 
           HsSumTy _ tys                  -> gos tys
    295 
    -      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2
    295 
    +      HsOpTy _ ty1 tyop ty2          -> go tyop && go ty1 && go ty2
    296 296 
           HsParTy _ ty                   -> go ty
    297 297 
           HsIParamTy _ _ ty              -> go ty
    298 298 
           HsKindSig _ ty kind            -> go ty && go kind

  • compiler/GHC/ThToHs.hs
    ... ... @@ -1870,7 +1870,7 @@ cvtTypeKind typeOrKind ty
    1870 1870 
                        let px = parenthesizeHsType opPrec x'
    1871 1871 
                            py = parenthesizeHsType opPrec y'
    1872 1872 
                        in do { eq_tc <- returnLA eqTyCon_RDR
    1873 
    -                         ; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) }
    1873 
    +                         ; returnLA (mkHsOpTy NotPromoted px eq_tc py) }
    1874 1874 
                    -- The long-term goal is to remove the above case entirely and
    1875 1875 
                    -- subsume it under the case for InfixT. See #15815, comment:6,
    1876 1876 
                    -- for more details.

  • compiler/Language/Haskell/Syntax/Type.hs
    ... ... @@ -806,13 +806,13 @@ data HsType pass
    806 806 
           , hst_ctxt  :: LHsContext pass  -- Context C => blah
    807 807 
           , hst_body  :: LHsType pass }
    808 808
    809 
    +  -- | Type variable, type constructor, or (promoted) data constructor.
    810 
    +  --
    811 
    +  -- Includes named wildcards (such as @_foo@), but not bare wildcards @_@.
    809 812 
       | HsTyVar  (XTyVar pass)
    810 
    -              PromotionFlag    -- Whether explicitly promoted,
    811 
    -                               -- for the pretty printer
    812 
    -             (LIdOccP pass)
    813 
    -                  -- Type variable, type constructor, or data constructor
    814 
    -                  -- see Note [Promotions (HsTyVar)]
    815 
    -                  -- See Note [Located RdrNames] in GHC.Hs.Expr
    813 
    +              PromotionFlag    -- ^ Whether explicitly promoted, for the pretty printer.
    814 
    +                               -- See Note [Promotions (HsTyVar)]
    815 
    +             (LIdOccP pass)    -- ^ See Note [Located RdrNames] in GHC.Hs.Expr
    816 816
    817 817 
       | HsAppTy             (XAppTy pass)
    818 818 
                             (LHsType pass)
    ... ... @@ -838,9 +838,9 @@ data HsType pass
    838 838 
                             [LHsType pass]  -- Element types (length gives arity)
    839 839
    840 840 
       | HsOpTy              (XOpTy pass)
    841 
    -                        PromotionFlag    -- Whether explicitly promoted,
    842 
    -                                         -- for the pretty printer
    843 
    -                        (LHsType pass) (LIdOccP pass) (LHsType pass)
    841 
    +                        (LHsType pass)  -- ^ First argument
    842 
    +                        (LHsType pass)  -- ^ Operator (always a @HsTyVar@ or a @HsWildCardTy@)
    843 
    +                        (LHsType pass)  -- ^ Second argument
    844 844
    845 845 
       | HsParTy             (XParTy pass)
    846 846 
                             (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr

  • testsuite/tests/parser/should_compile/DumpParsedAst.stderr
    ... ... @@ -388,7 +388,6 @@
    388 388 
                        []))
    389 389 
                      (HsOpTy
    390 390 
                       (NoExtField)
    391 
    -                  (NotPromoted)
    392 391 
                       (L
    393 392 
                        (EpAnn
    394 393 
                         (EpaSpan { DumpParsedAst.hs:11:11 })
    ... ... @@ -411,12 +410,22 @@
    411 410 
                       (L
    412 411 
                        (EpAnn
    413 412 
                         (EpaSpan { DumpParsedAst.hs:11:13 })
    414 
    -                    (NameAnnTrailing
    413 
    +                    (AnnListItem
    415 414 
                          [])
    416 415 
                         (EpaComments
    417 416 
                          []))
    418 
    -                   (Exact
    419 
    -                    {Name: :}))
    417 
    +                   (HsTyVar
    418 
    +                    (NoEpTok)
    419 
    +                    (NotPromoted)
    420 
    +                    (L
    421 
    +                     (EpAnn
    422 
    +                      (EpaSpan { DumpParsedAst.hs:11:13 })
    423 
    +                      (NameAnnTrailing
    424 
    +                       [])
    425 
    +                      (EpaComments
    426 
    +                       []))
    427 
    +                     (Exact
    428 
    +                      {Name: :}))))
    420 429 
                       (L
    421 430 
                        (EpAnn
    422 431 
                         (EpaSpan { DumpParsedAst.hs:11:15-16 })

  • testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
    ... ... @@ -335,7 +335,6 @@
    335 335 
                          []))
    336 336 
                        (HsOpTy
    337 337 
                         (NoExtField)
    338 
    -                    (NotPromoted)
    339 338 
                         (L
    340 339 
                          (EpAnn
    341 340 
                           (EpaSpan { DumpRenamedAst.hs:13:11 })
    ... ... @@ -360,14 +359,24 @@
    360 359 
                         (L
    361 360 
                          (EpAnn
    362 361 
                           (EpaSpan { DumpRenamedAst.hs:13:13 })
    363 
    -                      (NameAnnTrailing
    362 
    +                      (AnnListItem
    364 363 
                            [])
    365 364 
                           (EpaComments
    366 365 
                            []))
    367 
    -                     (WithUserRdr
    368 
    -                      (Exact
    369 
    -                       {Name: :})
    370 
    -                      {Name: :}))
    366 
    +                     (HsTyVar
    367 
    +                      (NoEpTok)
    368 
    +                      (NotPromoted)
    369 
    +                      (L
    370 
    +                       (EpAnn
    371 
    +                        (EpaSpan { DumpRenamedAst.hs:13:13 })
    372 
    +                        (NameAnnTrailing
    373 
    +                         [])
    374 
    +                        (EpaComments
    375 
    +                         []))
    376 
    +                       (WithUserRdr
    377 
    +                        (Exact
    378 
    +                         {Name: :})
    379 
    +                        {Name: :}))))
    371 380 
                         (L
    372 381 
                          (EpAnn
    373 382 
                           (EpaSpan { DumpRenamedAst.hs:13:15-16 })

  • testsuite/tests/parser/should_fail/T17865.stderr
    1 
    -
    2 
    -T17865.hs:3:11: error: [GHC-80236]
    1 
    +T17865.hs:3:10: error: [GHC-80236]
    3 2 
         Illegal promotion quote mark in the declaration of
    4 3 
         data/newtype constructor MkT
    5 4
    6 
    -T17865.hs:5:13: error: [GHC-80236]
    5 
    +T17865.hs:5:11: error: [GHC-80236]
    7 6 
         Illegal promotion quote mark in the declaration of
    8 7 
         data/newtype constructor MkT'
    9 8
    ... ... @@ -14,3 +13,4 @@ T17865.hs:7:16: error: [GHC-80236]
    14 13 
     T17865.hs:9:17: error: [GHC-80236]
    15 14 
         Illegal promotion quote mark in the declaration of
    16 15 
         data/newtype constructor (:>$)
    16 
    +

  • testsuite/tests/partial-sigs/should_compile/T11107.hs
    1 
    +{-# LANGUAGE PartialTypeSignatures #-}
    2 
    +module T11107 where
    3 
    +
    4 
    +e :: Int `_` Bool
    5 
    +e = Left 0
    \ No newline at end of file

  • testsuite/tests/partial-sigs/should_compile/T11107.stderr
    1 
    +T11107.hs:4:10: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
    2 
    +    • Found type wildcard ‘_’ standing for ‘Either :: * -> * -> *’
    3 
    +    • In the type signature: e :: Int `_` Bool
    4 
    +

  • testsuite/tests/partial-sigs/should_compile/all.T
    ... ... @@ -109,3 +109,4 @@ test('T22065', normal, compile, [''])
    109 109 
     test('T16152', normal, compile, [''])
    110 110 
     test('T20076', expect_broken(20076), compile, [''])
    111 111 
     test('T26256', normal, compile, [''])
    112 
    +test('T11107', normal, compile, [''])

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -3969,11 +3969,11 @@ instance ExactPrint (HsType GhcPs) where
    3969 3969 
         tys' <- markAnnotated tys
    3970 3970 
         an1 <- markClosingParen an0
    3971 3971 
         return (HsSumTy an1 tys')
    3972 
    -  exact (HsOpTy x promoted t1 lo t2) = do
    3972 
    +  exact (HsOpTy x t1 lo t2) = do
    3973 3973 
         t1' <- markAnnotated t1
    3974 3974 
         lo' <- markAnnotated lo
    3975 3975 
         t2' <- markAnnotated t2
    3976 
    -    return (HsOpTy x promoted t1' lo' t2')
    3976 
    +    return (HsOpTy x t1' lo' t2')
    3977 3977 
       exact (HsParTy (o,c) ty) = do
    3978 3978 
         o' <- markEpToken o
    3979 3979 
         ty' <- markAnnotated ty

  • utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
    ... ... @@ -102,7 +102,7 @@ dropHsDocTy = drop_sig_ty
    102 102 
         drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
    103 103 
         drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
    104 104 
         drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
    105 
    -    drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)
    105 
    +    drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) (drop_lty b) (drop_lty c)
    106 106 
         drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
    107 107 
         drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
    108 108 
         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 =
    1345 1345 
       hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]
    1346 1346 
     ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode =
    1347 1347 
       hsep [ppr_mono_lty fun_ty unicode, atSign <> ppr_mono_lty arg_ki unicode]
    1348 
    -ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode =
    1349 
    -  ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode
    1348 
    +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode
    1349 
    +  | Just pp_op <- ppr_infix_ty tyop
    1350 
    +  = pp_ty1 <+> pp_op <+> pp_ty2
    1351 
    +  | otherwise  -- This shouldn't happen unless the user constructs weird ASTs via the GHC API
    1352 
    +  = let pp_op = ppr_mono_lty tyop unicode
    1353 
    +    in hsep [hsep [pp_op, pp_ty1], pp_ty2]
    1350 1354 
       where
    1351 
    -    ppr_op_prom
    1352 
    -      | isPromoted prom =
    1353 
    -          char '\'' <> ppr_op
    1354 
    -      | otherwise =
    1355 
    -          ppr_op
    1356 
    -    ppr_op
    1357 
    -      | isSymOcc (getOccName op) = ppLDocName op
    1358 
    -      | otherwise = char '`' <> ppLDocName op <> char '`'
    1355 
    +    pp_ty1 = ppr_mono_lty ty1 unicode
    1356 
    +    pp_ty2 = ppr_mono_lty ty2 unicode
    1359 1357 
     ppr_mono_ty (HsParTy _ ty) unicode =
    1360 1358 
       parens (ppr_mono_lty ty unicode)
    1361 1359 
     --  = ppr_mono_lty ty unicode
    ... ... @@ -1367,6 +1365,18 @@ ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
    1367 1365 
     ppr_mono_ty (HsStarTy _) unicode = starSymbol unicode
    1368 1366 
     ppr_mono_ty (XHsType HsRedacted{}) _ = error "ppr_mono_ty: HsRedacted can't be used here"
    1369 1367
    1368 
    +ppr_infix_ty :: LHsType DocNameI -> Maybe LaTeX
    1369 
    +ppr_infix_ty (L _ (HsTyVar _ prom op)) = Just pp_op_prom
    1370 
    +  where
    1371 
    +    pp_op_prom
    1372 
    +      | isPromoted prom = char '\'' <> pp_op
    1373 
    +      | otherwise = pp_op
    1374 
    +    pp_op
    1375 
    +      | isSymOcc (getOccName op) = ppLDocName op
    1376 
    +      | otherwise = char '`' <> ppLDocName op <> char '`'
    1377 
    +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`")
    1378 
    +ppr_infix_ty _ = Nothing
    1379 
    +
    1370 1380 
     ppr_tylit :: HsLit DocNameI -> Bool -> LaTeX
    1371 1381 
     ppr_tylit (HsNatural _ n) _ = integer (il_value n)
    1372 1382 
     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 _ =
    1863 1863 
         [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts
    1864 1864 
         , atSign <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts
    1865 1865 
         ]
    1866 
    -ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _ =
    1867 
    -  ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
    1866 
    +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode qual _
    1867 
    +  | Just pp_op <- ppr_infix_ty tyop qual
    1868 
    +  = pp_ty1 <+> pp_op <+> pp_ty2
    1869 
    +  | otherwise  -- This shouldn't happen unless the user constructs weird ASTs via the GHC API
    1870 
    +  = let pp_op = ppr_mono_lty tyop unicode qual HideEmptyContexts
    1871 
    +    in hsep [hsep [pp_op, pp_ty1], pp_ty2]
    1868 1872 
       where
    1869 
    -    ppr_op_prom
    1870 
    -      | isPromoted prom =
    1871 
    -          promoQuote ppr_op
    1872 
    -      | otherwise =
    1873 
    -          ppr_op
    1874 
    -    ppr_op = ppLDocName qual Infix op
    1873 
    +    pp_ty1  = ppr_mono_lty ty1 unicode qual HideEmptyContexts
    1874 
    +    pp_ty2  = ppr_mono_lty ty2 unicode qual HideEmptyContexts
    1875 1875 
     ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts =
    1876 1876 
       parens (ppr_mono_lty ty unicode qual emptyCtxts)
    1877 1877 
     --  = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts)
    ... ... @@ -1882,6 +1882,16 @@ ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_'
    1882 1882 
     ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
    1883 1883 
     ppr_mono_ty (XHsType HsRedacted{}) _ _ _ = error "ppr_mono_ty: HsRedacted can't be used here"
    1884 1884
    1885 
    +ppr_infix_ty :: LHsType DocNameI -> Qualification -> Maybe Html
    1886 
    +ppr_infix_ty (L _ (HsTyVar _ prom op)) qual = Just pp_op_prom
    1887 
    +  where
    1888 
    +    pp_op_prom
    1889 
    +      | isPromoted prom = promoQuote pp_op
    1890 
    +      | otherwise = pp_op
    1891 
    +    pp_op = ppLDocName qual Infix op
    1892 
    +ppr_infix_ty (L _ (HsWildCardTy _)) _ = Just (toHtml ("`_`" :: LText))
    1893 
    +ppr_infix_ty _ _ = Nothing
    1894 
    +
    1885 1895 
     ppr_tylit :: HsLit DocNameI -> Html
    1886 1896 
     ppr_tylit (HsNatural _ n) = toHtml (show (il_value n))
    1887 1897 
     ppr_tylit (HsString  _ s) = toHtml (show s)

  • utils/haddock/haddock-api/src/Haddock/Convert.hs
    ... ... @@ -842,7 +842,8 @@ synifyType _ boundTvs (TyConApp tc tys) =
    842 842 
                       | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy ->
    843 843 
                           noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
    844 844 
                       | otherwise ->
    845 
    -                      noLocA $ HsOpTy noExtField IsPromoted hTy (noLocA $ noUserRdr $ getName tc) tTy
    845 
    +                      let tyop = noLocA $ HsTyVar noAnn IsPromoted (noLocA $ noUserRdr $ getName tc)
    846 
    +                      in noLocA $ HsOpTy noExtField hTy tyop tTy
    846 847 
           -- ditto for implicit parameter tycons
    847 848 
           | tc `hasKey` ipClassKey
    848 849 
           , [name, ty] <- tys
    ... ... @@ -854,9 +855,8 @@ synifyType _ boundTvs (TyConApp tc tys) =
    854 855 
               noLocA $
    855 856 
                 HsOpTy
    856 857 
                   noExtField
    857 
    -              NotPromoted
    858 858 
                   (synifyType WithinType boundTvs ty1)
    859 
    -              (noLocA $ noUserRdr eqTyConName)
    859 
    +              (noLocA $ HsTyVar noAnn NotPromoted (noLocA $ noUserRdr eqTyConName))
    860 860 
                   (synifyType WithinType boundTvs ty2)
    861 861 
           -- and infix type operators
    862 862 
           | isSymOcc (nameOccName (getName tc))
    ... ... @@ -864,9 +864,8 @@ synifyType _ boundTvs (TyConApp tc tys) =
    864 864 
               mk_app_tys
    865 865 
                 ( HsOpTy
    866 866 
                     noExtField
    867 
    -                prom
    868 867 
                     (synifyType WithinType boundTvs ty1)
    869 
    -                (noLocA $ noUserRdr $ getName tc)
    868 
    +                (noLocA $ HsTyVar noAnn prom (noLocA $ noUserRdr $ getName tc))
    870 869 
                     (synifyType WithinType boundTvs ty2)
    871 870 
                 )
    872 871 
                 tys_rest

  • utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
    ... ... @@ -465,8 +465,8 @@ reparenTypePrec = go
    465 465 
           paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
    466 466 
         go p (HsAppKindTy x fun_ty arg_ki) =
    467 467 
           paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
    468 
    -    go p (HsOpTy x prom ty1 op ty2) =
    469 
    -      paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2)
    468 
    +    go p (HsOpTy x ty1 op ty2) =
    469 
    +      paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
    470 470 
         go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
    471 471 
         go _ t@HsTyVar{} = t
    472 472 
         go _ t@HsStarTy{} = t

  • utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
    ... ... @@ -399,11 +399,11 @@ renameType t = case t of
    399 399 
         return (HsAppTy noAnn lhs rhs)
    400 400 
       HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
    401 401 
       HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
    402 
    -  HsOpTy _ prom a (L loc op) b -> do
    403 
    -    op' <- renameName (getName op)
    402 
    +  HsOpTy _ a op b -> do
    403 
    +    op' <- renameLType op
    404 404 
         a' <- renameLType a
    405 405 
         b' <- renameLType b
    406 
    -    return (HsOpTy noAnn prom a' (L loc op') b')
    406 
    +    return (HsOpTy noAnn a' op' b')
    407 407 
       HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
    408 408 
       HsKindSig _ ty k -> do
    409 409 
         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
    104 104 
     renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
    105 105 
     renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
    106 106 
     renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
    107 
    -renameType (HsOpTy x f la lop lb) =
    108 
    -  HsOpTy x <$> pure f <*> renameLType la <*> renameLNameOcc lop <*> renameLType lb
    107 
    +renameType (HsOpTy x la lop lb) =
    108 
    +  HsOpTy x <$> renameLType la <*> renameLType lop <*> renameLType lb
    109 109 
     renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
    110 110 
     renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
    111 111 
     renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help