Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: af06dc63 by Brandon Chinn at 2026-11-01T17:03:37-08:00 [ci skip] wip - - - - - 14 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/Lexer/String.x - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/String.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - testsuite/tests/parser/should_run/StringInterpolation.hs - testsuite/tests/printer/Makefile - + testsuite/tests/printer/PprStringInterpolation.hs - testsuite/tests/printer/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -27,7 +27,6 @@ import GHC.Hs.Pat import GHC.Hs.Lit import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Language.Haskell.Syntax.StringMeta (StringMeta (..)) import Language.Haskell.Syntax.Text import Language.Haskell.Syntax.Module.Name import GHC.Hs.Extension @@ -239,12 +238,12 @@ type instance XQualLitE (GhcPass _) = NoExtField type instance XLam (GhcPass _) = EpAnnLam type instance XApp (GhcPass _) = NoExtField -type instance XInterString GhcPs = NoExtField -type instance XInterString GhcRn = NoExtField +type instance XInterString GhcPs = AnnInterString +type instance XInterString GhcRn = AnnInterString type instance XInterString GhcTc = DataConCantHappen --- | Note: does not contain any delimiters -type instance XInterStringRaw (GhcPass _) = SourceText -type instance XInterStringExpr (GhcPass _) = NoExtField +type instance XInterStringRaw (GhcPass _) = SourceText -- Note: does not contain any delimiters +type instance XInterStringExpr (GhcPass _) = NoExtField +type instance XXInterStringPart (GhcPass _) = DataConCantHappen type instance XAppTypeE GhcPs = EpToken "@" type instance XAppTypeE GhcRn = NoExtField @@ -623,6 +622,18 @@ data AnnFunRhs instance NoAnn AnnFunRhs where noAnn = AnnFunRhs noAnn noAnn noAnn +data AnnInterString = AnnInterString + { ais_delim :: !AnnInterStringDelim + , ais_open :: !EpaLocation -- ^ @s"@ or @s"""@, including any @M.@ prefix + , ais_close :: !EpaLocation -- ^ @"@ or @"""@ + } + deriving (Data, Show, Eq) + +data AnnInterStringDelim + = AnnInterStringSingle -- ^ @s"..."@ + | AnnInterStringMulti -- ^ @s"""..."""@ + deriving (Data, Show, Eq) + -- --------------------------------------------------------------------- type instance XSCC (GhcPass _) = (AnnPragSCC, SourceText) @@ -821,21 +832,26 @@ ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsQualLit _ lit) = ppr lit -ppr_expr (HsInterString _ meta parts) = +ppr_expr (HsInterString x _ parts) = char 's' <> delim <> hcat (map pprInterPart parts) <> delim where + isMultiline = + case (ghcPass @p, x) of + (GhcPs, AnnInterString{ais_delim = AnnInterStringMulti}) -> True + (GhcRn, AnnInterString{ais_delim = AnnInterStringMulti}) -> True + _ -> False delim - | strMetaMultiline meta = text "\"\"\"" + | isMultiline = text "\"\"\"" | otherwise = char '"' pprInterPart = \case HsInterStringExpr _ expr -> text "${" <> ppr_lexpr expr <> text "}" HsInterStringRaw st s -> case st of SourceText src - | strMetaMultiline meta -> vcat $ map text $ split '\n' (unpackFS src) + | isMultiline -> vcat $ map text $ split '\n' (unpackFS src) | otherwise -> ftext src NoSourceText - | strMetaMultiline meta -> pprHsStringMulti' (unpackHText s) + | isMultiline -> pprHsStringMulti' (unpackHText s) | otherwise -> pprHsString' (unpackHText s) ppr_expr (HsHole x) = case (ghcPass @p, x) of ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -584,8 +584,8 @@ addTickHsExpr e@(HsLit {}) = return e addTickHsExpr e@(HsQualLit {}) = return e addTickHsExpr (HsInterString x ty parts) = do parts' <- forM parts $ \case - part@(HsInterStringRaw {}) -> return part HsInterStringExpr x e -> HsInterStringExpr x <$> addTickLHsExpr e + p -> return p return $ HsInterString x ty parts' addTickHsExpr e@(HsEmbTy {}) = return e addTickHsExpr e@(HsStar {}) = return e ===================================== compiler/GHC/Parser.y ===================================== @@ -4419,9 +4419,18 @@ processStringInter :: processStringInter tokBegin parts tokEnd = do parts' <- mapM mkInterStringPartPV $ processRawLexedStrings parts ams1 (L (comb2 tokBegin tokEnd) ()) $ - HsInterString noExtField meta parts' + HsInterString ann (strMetaQualified meta) parts' where L _ (ITstringInterBegin meta) = tokBegin + ann = + AnnInterString + { ais_delim = + if strMetaMultiline meta + then AnnInterStringMulti + else AnnInterStringSingle + , ais_open = noAnn -- FIXME(bchinn) + , ais_close = noAnn -- FIXME(bchinn) + } processRawLexedStrings :: [Either (SourceText, RawLexedString) ECP] -> ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -2236,7 +2236,7 @@ tok_string_inter_begin meta span _ _ _ = do tok_string_inter_qual_begin :: StringMeta -> Action tok_string_inter_qual_begin meta span buf len buf2 = do - let modName = ModuleName $ lexemeToFastString buf modNameLen + let modName = HsModuleName $ lexemeToText buf modNameLen let meta' = meta{strMetaQualified = Just modName} tok_string_inter_begin meta' span buf len buf2 where ===================================== compiler/GHC/Parser/Lexer/String.x ===================================== @@ -91,7 +91,6 @@ $hexit = [$decdigit A-F a-f] -- Note [Lexing interpolated strings] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- -- Lexing interpolated strings will do the following steps: -- -- 1. Lex `s"` => push `string_inter_content` lex state ===================================== compiler/GHC/Parser/String.hs ===================================== @@ -32,6 +32,7 @@ import qualified Data.Foldable1 as Foldable1 import Data.Functor.Identity (Identity (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (listToMaybe, mapMaybe) +import GHC.Data.Maybe (rightToMaybe) import GHC.Data.OrdList (fromOL, nilOL, snocOL) import GHC.Data.StringBuffer (StringBuffer) import qualified GHC.Data.StringBuffer as StringBuffer @@ -51,7 +52,7 @@ data StringLexError = StringLexError LexErr BufPos deriving (Show, Eq) lexString :: Int -> StringBuffer -> Either StringLexError String -lexString = lexStringWith (fromRight . processCharsSingle) +lexString = lexStringWith (rightToMaybe . processCharsSingle) -- ----------------------------------------------------------------------------- -- Lexing interface @@ -194,7 +195,7 @@ resolveEscapes = go nilOL c : cs -> go (acc `snocOL` c) cs resolveEscapesMaybe :: HasChar c => [c] -> Maybe [c] -resolveEscapesMaybe = fromRight . resolveEscapes +resolveEscapesMaybe = rightToMaybe . resolveEscapes -- ----------------------------------------------------------------------------- -- Escape characters @@ -626,9 +627,3 @@ It's more precisely defined with the following algorithm: * Lines with only whitespace characters 3. Calculate the longest prefix of whitespace shared by all lines in the remaining list -} - --- ----------------------------------------------------------------------------- --- Other utilities - -fromRight :: Either e a -> Maybe a -fromRight = either (const Nothing) Just ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -379,9 +379,9 @@ rnExpr (HsOverLit x lit) return (HsApp noExtField (noLocA neg) (noLocA (HsOverLit x lit')) , fvs ) } -rnExpr (HsInterString _ meta parts) = do +rnExpr (HsInterString _ mQual parts) = do (parts', fvs1) <- unzip <$> mapM rnInterStringPart parts - (expr, fvs2) <- rewriteInterString meta parts' + (expr, fvs2) <- rewriteInterString mQual parts' pure (expr, plusFNs fvs1 `plusFN` fvs2) where rnInterStringPart = \case ===================================== compiler/GHC/Rename/String.hs ===================================== @@ -14,14 +14,14 @@ import GHC.Rename.Env (lookupNameWithQualifier, lookupSyntaxExpr, lookupSyntaxNa import GHC.Tc.Utils.Monad import GHC.Types.Name.Set (FreeNames, emptyFNs, plusFNs) import GHC.Types.SrcLoc (unLoc) -import Language.Haskell.Syntax.StringMeta (StringMeta (..)) +import Language.Haskell.Syntax.Module.Name (HsModuleName) {- Note [Desugaring interpolated strings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Cross-references: -* Note [Parsing interpolated strings] -* Note [Doing XXExprGhcRn in the Renamer vs Typechecker] + * Note [Parsing interpolated strings] + * Note [Doing XXExprGhcRn in the Renamer vs Typechecker] Interpolated strings are represented with the following HsExpr tree: @@ -52,10 +52,10 @@ can be typechecked as usual, without any additional work. -- have already been renamed, but handles renaming of overloaded strings, if -- necessary. rewriteInterString :: - StringMeta -> + Maybe HsModuleName -> [HsInterStringPart GhcRn] -> RnM (HsExpr GhcRn, FreeNames) -rewriteInterString meta parts = do +rewriteInterString mQual parts = do (mkOverloaded, fns1) <- get_mkOverloaded (rawName, fns2) <- lookupName KnownOccs.interpolateRawIdOcc (convertName, fns3) <- lookupName KnownOccs.interpolateValueIdOcc @@ -73,7 +73,7 @@ rewriteInterString meta parts = do pure (expr, plusFNs [fns1, fns2, fns3, fns4, fns5, fns6]) where lookupName = - case strMetaQualified meta of + case mQual of Just mod -> lookupNameWithQualifier mod Nothing -> lookupSyntaxName @@ -84,7 +84,7 @@ rewriteInterString meta parts = do -- Handle -XOverloadedStrings get_mkOverloaded = do overloaded <- xoptM LangExt.OverloadedStrings - if overloaded && isNothing (strMetaQualified meta) + if overloaded && isNothing mQual then do (fromStringExpr, fns) <- lookupSyntaxExpr KnownOccs.fromStringClassOpOcc pure (nlHsApp (noLocA fromStringExpr), fns) ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -21,7 +21,6 @@ import Language.Haskell.Syntax.Text import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.StringMeta (StringMeta) -- libraries: import Data.Data hiding (Fixity(..)) @@ -345,7 +344,7 @@ data HsExpr p | -- | See Note [Parsing interpolated strings] HsInterString (XInterString p) - StringMeta + (Maybe HsModuleName) [HsInterStringPart p] -- | Lambda, Lambda-case, and Lambda-cases @@ -591,6 +590,7 @@ data HsLamVariant data HsInterStringPart p = HsInterStringRaw (XInterStringRaw p) HText | HsInterStringExpr (XInterStringExpr p) (LHsExpr p) + | XHsInterStringPart !(XXInterStringPart p) {- Note [Parens in HsSyn] ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -500,6 +500,7 @@ type family XQualLitE x type family XInterString x type family XInterStringRaw x type family XInterStringExpr x +type family XXInterStringPart x type family XLam x type family XLamCase x type family XApp x ===================================== testsuite/tests/parser/should_run/StringInterpolation.hs ===================================== @@ -46,6 +46,14 @@ allTests = , expression = let s = "world" in s ++ s" hello ${s}" } + , TestCase -- dollars + { label = + """ + "$foo \$foo \${foo}" + """ + , expression = + "$foo \$foo \${foo}" + } , TestCase -- curly brace Char { label = """ @@ -54,6 +62,30 @@ allTests = , expression = s"a ${'}'} b" } + , TestCase -- interpolated multiline expression + { label = + """ + s"example ${fromMaybe + (0 :: Int) + (Just 10)} value" + """ + , expression = + s"example ${fromMaybe + (0 :: Int) + (Just 10)} value" + } + , TestCase -- interpolated expression blocks + { label = + """ + let a = s"${case True of True -> 1; False -> 2 :: Int}" + b = s"${do True}" + in a ++ b + """ + , expression = + let a = s"${case True of True -> 1; False -> 2 :: Int}" + b = s"${do True}" + in a ++ b + } , TestCase -- interpolated expression with comment { label = """ @@ -146,7 +178,24 @@ allTests = , expression = let x = "test" in s"a “${x}” b" } - -- TODO(bchinn): interpolated multiline strings + , TestCase -- interpolated multiline strings + { label = + """ + let x = "test" in + s\""" + line one + ${x} + a "quoted value" + \""" + """ + , expression = + let x = "test" in + s""" + line one + ${x} + a "quoted value" + """ + } ] {----- Types for tests -----} ===================================== testsuite/tests/printer/Makefile ===================================== @@ -933,6 +933,11 @@ PprQualifiedStrings: $(CHECK_PPR) $(LIBDIR) PprQualifiedStrings.hs $(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs +.PHONY: PprStringInterpolation +PprStringInterpolation: + $(CHECK_PPR) $(LIBDIR) PprStringInterpolation.hs + $(CHECK_EXACT) $(LIBDIR) PprStringInterpolation.hs + .PHONY: Haddock1 Haddock1: # $(CHECK_PPR) $(LIBDIR) Haddock1.hs ===================================== testsuite/tests/printer/PprStringInterpolation.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE QualifiedStrings #-} +{-# LANGUAGE StringInterpolation #-} + +module PprQualifiedStrings where + +import qualified Example.Text as Text + +exprs :: IO () +exprs = do + let name = "Alice" + print s"My name is: ${name}. Nice to meet you!" + print s""" + My name is: + ${name} + Nice to meet you! + """ + print Text.s"My name is: ${name}. Nice to meet you!" + print Text.s""" + My name is: + ${name} + Nice to meet you! + """ ===================================== testsuite/tests/printer/all.T ===================================== @@ -226,3 +226,4 @@ test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQu test('Haddock1', [ignore_stderr,req_ppr_deps], makefile_test, ['Haddock1']) test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c']) test('PprStringNoSourceText', normal, compile, ['']) +test('PprStringInterpolation', [ignore_stderr,req_ppr_deps], makefile_test, ['PprStringInterpolation']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af06dc63a7e2fd695d3264d3c9ad5745... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/af06dc63a7e2fd695d3264d3c9ad5745... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help