Brandon Chinn pushed to branch wip/T26503 at Glasgow Haskell Compiler / GHC Commits: 6dfed3a3 by Brandon Chinn at 2026-01-20T21:36:48-08:00 Address feedback - - - - - 12 changed files: - compiler/GHC/Hs/Lit.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Pat.hs - + testsuite/tests/qualified-strings/should_fail/Example/Length.hs - testsuite/tests/qualified-strings/should_fail/all.T - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.stderr - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.stderr - + testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.hs - + testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.stderr Changes: ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Module.Name (moduleNameString) {- ************************************************************************ @@ -211,14 +212,18 @@ Equivalently it's True if instance IsPass p => Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) - ppr (HsString StringMeta{..} s) - -- multiline strings - | strMetaMultiline = + ppr (HsString StringMeta{..} s) = + handleQualified $ if strMetaMultiline then renderMultiline else renderNormal + where + handleQualified = + case strMetaQualified of + Nothing -> id + Just modName -> (text (moduleNameString modName ++ ".") <>) + renderMultiline = case strMetaSrc of NoSourceText -> pprHsString s - SourceText src -> vcat $ map text $ split '\n' (unpackFS src) - -- normal strings - | otherwise = pprWithSourceText strMetaSrc (pprHsString s) + SourceText src -> vcat . map text . split '\n' . unpackFS $ src + renderNormal = pprWithSourceText strMetaSrc (pprHsString s) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) = pprWithSourceText (il_text i) (integer (il_value i)) ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -39,6 +39,7 @@ import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Type import GHC.Data.Maybe import GHC.Types.SourceText (FractionalLit(..)) +import GHC.Types.StringMeta (StringMeta(..)) import Control.Monad (zipWithM, replicateM) import Data.List (elemIndex) import Data.List.NonEmpty ( NonEmpty(..) ) @@ -137,6 +138,11 @@ desugarPat x pat = case pat of , is_to_list (unLoc lrhs) -> desugarLPat x pat + -- Desugar qualified string literals the same as RebindableSyntax + LitPat _ (HsString StringMeta{strMetaQualified = Just _} s) + | ViewPat ty _ _ <- expansion + -> mkPmLitGrds x $ PmLit ty (PmLitOverString s) + _ -> desugarPat x expansion -- See Note [Desugar CoPats] ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -359,7 +359,8 @@ rnExpr (HsLit x lit) | Just (meta, s) <- stringLike lit | StringMeta{strMetaQualified = Just modName} <- meta -> do (qualifiedFromString, fvs) <- first genHsVar <$> lookupNameWithQualifier fromStringName modName let hsLit = HsLit x (convertLit lit) - return (HsApp noExtField (noLocA qualifiedFromString) (noLocA hsLit), fvs) + let expr = HsApp noExtField (noLocA qualifiedFromString) (noLocA hsLit) + return (mkExpandedExpr hsLit expr, fvs) | opt_OverloadedStrings -> rnExpr (HsOverLit x (mkHsIsString (strMetaSrc meta) s)) | otherwise -> do { ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -567,13 +567,14 @@ rnPatAndThen mk (LitPat x lit) -- M."asdf" => ((M.fromString "asdf" ==) -> True) eqExpr <- liftCpsFV $ lookupSyntaxExpr eqName fromStringExpr <- fmap genHsVar $ liftCpsFV $ lookupNameWithQualifier fromStringName modName - let lit = noLocA $ HsLit noExtField (mkHsStringFS s) - let trueExpr = noLocA $ + let litExpr = noLocA $ HsLit noExtField (convertLit lit) + truePat = noLocA $ ConPat noExtField (noLocA $ noUserRdr trueDataConName) (PrefixCon []) - return $ ViewPat Nothing (genLHsApp eqExpr (genLHsApp fromStringExpr lit)) trueExpr + return . mkExpandedPat (LitPat x (convertLit lit)) $ + ViewPat Nothing (genLHsApp eqExpr (genLHsApp fromStringExpr litExpr)) truePat | opt_OverloadedStrings -> rnPatAndThen mk (mkNPat (noLocA (mkHsIsString (strMetaSrc meta) s)) ===================================== testsuite/tests/qualified-strings/should_fail/Example/Length.hs ===================================== @@ -0,0 +1,4 @@ +module Example.Length where + +fromString :: String -> Int +fromString = length ===================================== testsuite/tests/qualified-strings/should_fail/all.T ===================================== @@ -1,3 +1,8 @@ setTestOpts(only_ways(['normal'])); +qextra_files = extra_files(['Example']) + test('qstrings_multiline_no_ext', normal, compile_fail, ['']) +test('qstrings_bad_expr', [qextra_files], multimod_compile_fail, ['qstrings_bad_expr', '']) +test('qstrings_bad_pat', [qextra_files], multimod_compile_fail, ['qstrings_bad_pat', '']) +test('qstrings_redundant_pattern', [qextra_files], multimod_compile_fail, ['qstrings_redundant_pattern', '']) ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE QualifiedStrings #-} + +import qualified Example.Length as Length + +main :: IO () +main = putStrLn Length."this fails after being converted into an Int" ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.stderr ===================================== @@ -0,0 +1,15 @@ +[1 of 3] Compiling Example.Length ( Example/Length.hs, Example/Length.o ) +[2 of 3] Compiling Main ( qstrings_bad_expr.hs, qstrings_bad_expr.o ) +qstrings_bad_expr.hs:6:17: error: [GHC-83865] + • Couldn't match type ‘Int’ with ‘[Char]’ + Expected: String + Actual: Int + • In the first argument of ‘putStrLn’, namely + ‘Length."this fails after being converted into an Int"’ + In the expression: + putStrLn + Length."this fails after being converted into an Int" + In an equation for ‘main’: + main + = putStrLn + Length."this fails after being converted into an Int" ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE QualifiedStrings #-} + +import qualified Example.Length as Length + +main :: IO () +main = + case "" of + Length."this fails after being converted into an Int" -> pure () + _ -> pure () ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.stderr ===================================== @@ -0,0 +1,15 @@ +[1 of 3] Compiling Example.Length ( Example/Length.hs, Example/Length.o ) +[2 of 3] Compiling Main ( qstrings_bad_pat.hs, qstrings_bad_pat.o ) +qstrings_bad_pat.hs:8:5: error: [GHC-83865] + • Couldn't match type ‘[Char]’ with ‘Int’ + Expected: String + Actual: Int + • In the pattern: + Length."this fails after being converted into an Int" + In a case alternative: + Length."this fails after being converted into an Int" + -> pure () + In the expression: + case "" of + Length."this fails after being converted into an Int" -> pure () + _ -> pure () ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE QualifiedStrings #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +import qualified Example.Length as Length + +main :: IO () +main = print $ foo Length."abc" + +foo :: Int -> () +foo Length."abc" = () +foo other = + case other of + Length."abc" -> () + Length."def" -> () + _ -> () ===================================== testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.stderr ===================================== @@ -0,0 +1,6 @@ +[1 of 3] Compiling Example.Length ( Example/Length.hs, Example/Length.o ) +[2 of 3] Compiling Main ( qstrings_redundant_pattern.hs, qstrings_redundant_pattern.o ) +qstrings_redundant_pattern.hs:13:5: error: [GHC-53633] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns] + Pattern match is redundant + In a case alternative: Length."abc" -> ... + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6dfed3a3d0b444bc6b971a6e32ba9ef6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6dfed3a3d0b444bc6b971a6e32ba9ef6... You're receiving this email because of your account on gitlab.haskell.org.