recursion-ninja pushed to branch wip/fix-26953 at Glasgow Haskell Compiler / GHC
Commits:
-
5374601f
by Recursion Ninja at 2026-06-23T09:30:08-04:00
5 changed files:
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Parser.y
- compiler/GHC/Unit/Module/Warnings.hs
- libraries/process
- utils/check-exact/ExactPrint.hs
Changes:
| ... | ... | @@ -504,7 +504,7 @@ instance Outputable (FractionalLit (GhcPass p)) where |
| 504 | 504 | rat = fl_signi * (base ^^ fl_exp)
|
| 505 | 505 | in pprWithSourceText fl_text $ rational rat
|
| 506 | 506 | |
| 507 | --- The 'Show[ instance is required for the derived
|
|
| 507 | +-- The 'Show' instance is required for the derived
|
|
| 508 | 508 | -- 'GHC.Parser.Lexer.Token' instance when DEBUG is enabled.
|
| 509 | 509 | instance Show (FractionalLit (GhcPass p)) where
|
| 510 | 510 | show (FL{..}) = unwords
|
| ... | ... | @@ -677,6 +677,10 @@ instance Eq (StringLiteral (GhcPass p)) where |
| 677 | 677 | instance Outputable (StringLiteral (GhcPass p)) where
|
| 678 | 678 | ppr (StringLiteral{..}) = pprWithSourceText sl_src (doubleQuotes $ ftext sl_fs)
|
| 679 | 679 | |
| 680 | +-- The 'Show' instance is required the 'parsed' test case of GHC's test-suite.
|
|
| 681 | +instance Show (StringLiteral (GhcPass p)) where
|
|
| 682 | + show (StringLiteral srcTxt litFS) = unwords [ show srcTxt, show litFS ]
|
|
| 683 | + |
|
| 680 | 684 | -- | Get the 'SourceText' of a 'StringLiteral'
|
| 681 | 685 | {-# INLINE stringLitSourceText #-}
|
| 682 | 686 | stringLitSourceText :: StringLiteral (GhcPass p) -> SourceText
|
| ... | ... | @@ -2074,10 +2074,10 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. |
| 2074 | 2074 | |
| 2075 | 2075 | maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
|
| 2076 | 2076 | : '{-# DEPRECATED' strings '#-}'
|
| 2077 | - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
|
|
| 2077 | + {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2))
|
|
| 2078 | 2078 | (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
|
| 2079 | 2079 | | '{-# WARNING' warning_category strings '#-}'
|
| 2080 | - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))
|
|
| 2080 | + {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3))
|
|
| 2081 | 2081 | (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
|
| 2082 | 2082 | | {- empty -} { Nothing }
|
| 2083 | 2083 | |
| ... | ... | @@ -2107,7 +2107,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } |
| 2107 | 2107 | : warning_category namespace_spec namelist strings
|
| 2108 | 2108 | {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
|
| 2109 | 2109 | (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3)
|
| 2110 | - (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
|
|
| 2110 | + (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) }
|
|
| 2111 | 2111 | |
| 2112 | 2112 | namespace_spec :: { Located (NamespaceSpecifier GhcPs) }
|
| 2113 | 2113 | : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
|
| ... | ... | @@ -2135,24 +2135,24 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } |
| 2135 | 2135 | deprecation :: { OrdList (LWarnDecl GhcPs) }
|
| 2136 | 2136 | : namespace_spec namelist strings
|
| 2137 | 2137 | {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2)
|
| 2138 | - (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
|
|
| 2138 | + (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) }
|
|
| 2139 | 2139 | |
| 2140 | -strings :: { Located ((EpToken "[", EpToken "]"),[Located (StringLiteral GhcPs)]) }
|
|
| 2141 | - : STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }
|
|
| 2140 | +strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) }
|
|
| 2141 | + : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) }
|
|
| 2142 | 2142 | | '[' stringlist ']' { sLL $1 $> $ ((epTok $1,epTok $3),fromOL (unLoc $2)) }
|
| 2143 | 2143 | |
| 2144 | -stringlist :: { Located (OrdList (Located (StringLiteral GhcPs))) }
|
|
| 2144 | +stringlist :: { Located (OrdList (LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs))) }
|
|
| 2145 | 2145 | : stringlist ',' STRING {% if isNilOL (unLoc $1)
|
| 2146 | 2146 | then return (sLL $1 $> (unLoc $1 `snocOL`
|
| 2147 | - (L (gl $3) (getStringLiteral $3))))
|
|
| 2147 | + (stringLiteralToHsDocWst (L (gl $3) (getStringLiteral $3)))))
|
|
| 2148 | 2148 | else case (unLoc $1) of
|
| 2149 | 2149 | SnocOL hs t -> do
|
| 2150 | - let { t' = addTrailingCommaS t (glR $2) }
|
|
| 2150 | + t' <- addTrailingCommaA t (epTok $2)
|
|
| 2151 | 2151 | return (sLL $1 $> (snocOL hs t' `snocOL`
|
| 2152 | - (L (gl $3) (getStringLiteral $3))))
|
|
| 2152 | + (stringLiteralToHsDocWst (L (gl $3) (getStringLiteral $3)))))
|
|
| 2153 | 2153 | |
| 2154 | 2154 | }
|
| 2155 | - | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }
|
|
| 2155 | + | STRING { sLL $1 $> (unitOL (stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1)))) }
|
|
| 2156 | 2156 | | {- empty -} { noLoc nilOL }
|
| 2157 | 2157 | |
| 2158 | 2158 | -----------------------------------------------------------------------------
|
| ... | ... | @@ -4374,7 +4374,7 @@ getSCC lt = do let s = getSTRING lt |
| 4374 | 4374 | then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC
|
| 4375 | 4375 | else return s
|
| 4376 | 4376 | |
| 4377 | -stringLiteralToHsDocWst :: Located (StringLiteral GhcPs) -> LocatedE (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)
|
|
| 4377 | +stringLiteralToHsDocWst :: Located (StringLiteral GhcPs) -> LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)
|
|
| 4378 | 4378 | stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl
|
| 4379 | 4379 | |
| 4380 | 4380 | -- Utilities for combining source spans
|
| ... | ... | @@ -4802,9 +4802,6 @@ addTrailingCommaN (L anns a) span = do |
| 4802 | 4802 | else addTrailingCommaToN anns (srcSpan2e span)
|
| 4803 | 4803 | return (L anns' a)
|
| 4804 | 4804 | |
| 4805 | -addTrailingCommaS :: Located (StringLiteral GhcPs) -> EpaLocation -> Located (StringLiteral GhcPs)
|
|
| 4806 | -addTrailingCommaS (L l sl) span = L (widenSpanL l [span]) sl
|
|
| 4807 | - |
|
| 4808 | 4805 | -- -------------------------------------
|
| 4809 | 4806 | |
| 4810 | 4807 | addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a
|
| ... | ... | @@ -139,7 +139,7 @@ warningTxtCategory _ = defaultWarningCategory |
| 139 | 139 | -- | The message that the WarningTxt was specified to output
|
| 140 | 140 | warningTxtMessage ::
|
| 141 | 141 | WarningTxt (GhcPass p) ->
|
| 142 | - [LocatedE (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))]
|
|
| 142 | + [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))]
|
|
| 143 | 143 | warningTxtMessage (WarningTxt _ _ m) = m
|
| 144 | 144 | warningTxtMessage (DeprecatedTxt _ m) = m
|
| 145 | 145 | |
| ... | ... | @@ -165,7 +165,7 @@ type instance XXWarningTxt (GhcPass _) = DataConCantHappen |
| 165 | 165 | type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText)
|
| 166 | 166 | type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
|
| 167 | 167 | |
| 168 | -type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = EpaLocation
|
|
| 168 | +type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA
|
|
| 169 | 169 | type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
|
| 170 | 170 | type instance Anno (WarningCategory) = EpaLocation
|
| 171 | 171 | type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
|
| ... | ... | @@ -203,7 +203,7 @@ instance Outputable (WarningTxt (GhcPass pass)) where |
| 203 | 203 | NoSourceText -> pp_ws ds
|
| 204 | 204 | SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
|
| 205 | 205 | |
| 206 | -pp_ws :: [LocatedE (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc
|
|
| 206 | +pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc
|
|
| 207 | 207 | pp_ws [l] = ppr $ unLoc l
|
| 208 | 208 | pp_ws ws
|
| 209 | 209 | = text "["
|
| 1 | -Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 |
|
| 1 | +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 |
| ... | ... | @@ -1962,8 +1962,7 @@ instance Typeable p => ExactPrint (StringLiteral (GhcPass p)) where |
| 1962 | 1962 | printSourceTextAA srcTxt (show (unpackFS fstStr))
|
| 1963 | 1963 | return (StringLiteral srcTxt fstStr)
|
| 1964 | 1964 | |
| 1965 | -{-
|
|
| 1966 | -instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where
|
|
| 1965 | +instance Typeable p => ExactPrint (LocatedN (StringLiteral (GhcPass p))) where
|
|
| 1967 | 1966 | getAnnotationEntry (L sann _) = fromAnn sann
|
| 1968 | 1967 | setAnnotationAnchor = setAnchorAn
|
| 1969 | 1968 | |
| ... | ... | @@ -1971,7 +1970,7 @@ instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where |
| 1971 | 1970 | ann' <-
|
| 1972 | 1971 | case ann of
|
| 1973 | 1972 | NameAnn a l t -> do
|
| 1974 | - mn <- markName a (Just (l,n))
|
|
| 1973 | + mn <- markName a (Just (l, mkVarUnqual (sl_fs n)))
|
|
| 1975 | 1974 | case mn of
|
| 1976 | 1975 | (a', (Just (l',_n))) -> do
|
| 1977 | 1976 | return (NameAnn a' l' t)
|
| ... | ... | @@ -2000,10 +1999,10 @@ instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where |
| 2000 | 1999 | (L name' _) <- markAnnotated (L name n)
|
| 2001 | 2000 | return (NameAnnQuote q' name' t)
|
| 2002 | 2001 | NameAnnTrailing t -> do
|
| 2003 | - _anc' <- printUnicode anc n
|
|
| 2002 | + let str = sourceTextToString (stringLitSourceText n) (show (unpackFS (sl_fs n)))
|
|
| 2003 | + _ <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str
|
|
| 2004 | 2004 | return (NameAnnTrailing t)
|
| 2005 | 2005 | return (L (EpAnn anc ann' cs) n)
|
| 2006 | --}
|
|
| 2007 | 2006 | |
| 2008 | 2007 | -- ---------------------------------------------------------------------
|
| 2009 | 2008 | |
| ... | ... | @@ -2717,11 +2716,7 @@ instance ExactPrint (Sig GhcPs) where |
| 2717 | 2716 | exact (SCCFunSig ((o,c),src) ln ml) = do
|
| 2718 | 2717 | o' <- markAnnOpen'' o src "{-# SCC"
|
| 2719 | 2718 | ln' <- markAnnotated ln
|
| 2720 | - ml' <- case ml of
|
|
| 2721 | - Nothing -> return Nothing
|
|
| 2722 | - Just (L loc sl) -> do
|
|
| 2723 | - L loc' _ <- markAnnotated (L loc (mkVarUnqual (sl_fs sl)))
|
|
| 2724 | - return . Just $ L loc' sl
|
|
| 2719 | + ml' <- markAnnotated ml
|
|
| 2725 | 2720 | c' <- markEpToken c
|
| 2726 | 2721 | return (SCCFunSig ((o',c'),src) ln' ml')
|
| 2727 | 2722 |