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 The fix for test cases: - Ppr035 - Ppr036 - Ppr048 - parsed Correcting WARNING/DEPRECATED/SCC pragma round-tripping - - - - - 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: ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -504,7 +504,7 @@ instance Outputable (FractionalLit (GhcPass p)) where rat = fl_signi * (base ^^ fl_exp) in pprWithSourceText fl_text $ rational rat --- The 'Show[ instance is required for the derived +-- The 'Show' instance is required for the derived -- 'GHC.Parser.Lexer.Token' instance when DEBUG is enabled. instance Show (FractionalLit (GhcPass p)) where show (FL{..}) = unwords @@ -677,6 +677,10 @@ instance Eq (StringLiteral (GhcPass p)) where instance Outputable (StringLiteral (GhcPass p)) where ppr (StringLiteral{..}) = pprWithSourceText sl_src (doubleQuotes $ ftext sl_fs) +-- The 'Show' instance is required the 'parsed' test case of GHC's test-suite. +instance Show (StringLiteral (GhcPass p)) where + show (StringLiteral srcTxt litFS) = unwords [ show srcTxt, show litFS ] + -- | Get the 'SourceText' of a 'StringLiteral' {-# INLINE stringLitSourceText #-} stringLitSourceText :: StringLiteral (GhcPass p) -> SourceText ===================================== compiler/GHC/Parser.y ===================================== @@ -2074,10 +2074,10 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) + {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3)) + {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3)) (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} | {- empty -} { Nothing } @@ -2107,7 +2107,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } + (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2135,24 +2135,24 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } + (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) } -strings :: { Located ((EpToken "[", EpToken "]"),[Located (StringLiteral GhcPs)]) } - : STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) } +strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) } + : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) } | '[' stringlist ']' { sLL $1 $> $ ((epTok $1,epTok $3),fromOL (unLoc $2)) } -stringlist :: { Located (OrdList (Located (StringLiteral GhcPs))) } +stringlist :: { Located (OrdList (LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs))) } : stringlist ',' STRING {% if isNilOL (unLoc $1) then return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getStringLiteral $3)))) + (stringLiteralToHsDocWst (L (gl $3) (getStringLiteral $3))))) else case (unLoc $1) of SnocOL hs t -> do - let { t' = addTrailingCommaS t (glR $2) } + t' <- addTrailingCommaA t (epTok $2) return (sLL $1 $> (snocOL hs t' `snocOL` - (L (gl $3) (getStringLiteral $3)))) + (stringLiteralToHsDocWst (L (gl $3) (getStringLiteral $3))))) } - | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } + | STRING { sLL $1 $> (unitOL (stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1)))) } | {- empty -} { noLoc nilOL } ----------------------------------------------------------------------------- @@ -4374,7 +4374,7 @@ getSCC lt = do let s = getSTRING lt then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC else return s -stringLiteralToHsDocWst :: Located (StringLiteral GhcPs) -> LocatedE (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs) +stringLiteralToHsDocWst :: Located (StringLiteral GhcPs) -> LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs) stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl -- Utilities for combining source spans @@ -4802,9 +4802,6 @@ addTrailingCommaN (L anns a) span = do else addTrailingCommaToN anns (srcSpan2e span) return (L anns' a) -addTrailingCommaS :: Located (StringLiteral GhcPs) -> EpaLocation -> Located (StringLiteral GhcPs) -addTrailingCommaS (L l sl) span = L (widenSpanL l [span]) sl - -- ------------------------------------- addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -139,7 +139,7 @@ warningTxtCategory _ = defaultWarningCategory -- | The message that the WarningTxt was specified to output warningTxtMessage :: WarningTxt (GhcPass p) -> - [LocatedE (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] + [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] warningTxtMessage (WarningTxt _ _ m) = m warningTxtMessage (DeprecatedTxt _ m) = m @@ -165,7 +165,7 @@ type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen -type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = EpaLocation +type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP @@ -203,7 +203,7 @@ instance Outputable (WarningTxt (GhcPass pass)) where NoSourceText -> pp_ws ds SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" -pp_ws :: [LocatedE (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc +pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 +Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1962,8 +1962,7 @@ instance Typeable p => ExactPrint (StringLiteral (GhcPass p)) where printSourceTextAA srcTxt (show (unpackFS fstStr)) return (StringLiteral srcTxt fstStr) -{- -instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where +instance Typeable p => ExactPrint (LocatedN (StringLiteral (GhcPass p))) where getAnnotationEntry (L sann _) = fromAnn sann setAnnotationAnchor = setAnchorAn @@ -1971,7 +1970,7 @@ instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where ann' <- case ann of NameAnn a l t -> do - mn <- markName a (Just (l,n)) + mn <- markName a (Just (l, mkVarUnqual (sl_fs n))) case mn of (a', (Just (l',_n))) -> do return (NameAnn a' l' t) @@ -2000,10 +1999,10 @@ instance ExactPrint (LocatedN (StringLiteral (GhcPass p))) where (L name' _) <- markAnnotated (L name n) return (NameAnnQuote q' name' t) NameAnnTrailing t -> do - _anc' <- printUnicode anc n + let str = sourceTextToString (stringLitSourceText n) (show (unpackFS (sl_fs n))) + _ <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str return (NameAnnTrailing t) return (L (EpAnn anc ann' cs) n) --} -- --------------------------------------------------------------------- @@ -2717,11 +2716,7 @@ instance ExactPrint (Sig GhcPs) where exact (SCCFunSig ((o,c),src) ln ml) = do o' <- markAnnOpen'' o src "{-# SCC" ln' <- markAnnotated ln - ml' <- case ml of - Nothing -> return Nothing - Just (L loc sl) -> do - L loc' _ <- markAnnotated (L loc (mkVarUnqual (sl_fs sl))) - return . Just $ L loc' sl + ml' <- markAnnotated ml c' <- markEpToken c return (SCCFunSig ((o',c'),src) ln' ml') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5374601f0ac20d33fc8d40a2bdf850c9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5374601f0ac20d33fc8d40a2bdf850c9... You're receiving this email because of your account on gitlab.haskell.org.