[Git][ghc/ghc][wip/interpolated-strings] Prototype implicit-no-builder + QualifiedLiterals

Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: d114d7dd by Brandon Chinn at 2025-04-30T08:45:58-07:00 Prototype implicit-no-builder + QualifiedLiterals - - - - - 29 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/String.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Expr.hs - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - testsuite/tests/driver/T4437.hs - testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs - + testsuite/tests/parser/should_run/StringInterpolationQualified.hs - + testsuite/tests/parser/should_run/StringInterpolationQualified.stdout - + testsuite/tests/parser/should_run/StringInterpolationQualified_SQL.hs - testsuite/tests/parser/should_run/all.T Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -286,7 +286,7 @@ basicKnownKeyNames fromStringName, -- Interpolated strings - fromBuilderName, toBuilderName, interpolateName, + interpolateName, -- Enum stuff enumFromName, enumFromThenName, @@ -1123,9 +1123,7 @@ minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpK negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey -- Module GHC.Internal.Data.String.Interpolate -toBuilderName, fromBuilderName, interpolateName :: Name -toBuilderName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "toBuilder") toBuilderKey -fromBuilderName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "fromBuilder") fromBuilderKey +interpolateName :: Name interpolateName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolate") interpolateKey --------------------------------- @@ -2502,9 +2500,7 @@ proxyHashKey :: Unique proxyHashKey = mkPreludeMiscIdUnique 502 -- String interpolation -toBuilderKey, fromBuilderKey, interpolateKey :: Unique -toBuilderKey = mkPreludeMiscIdUnique 574 -fromBuilderKey = mkPreludeMiscIdUnique 575 +interpolateKey :: Unique interpolateKey = mkPreludeMiscIdUnique 576 ---------------- Template Haskell ------------------- ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -260,6 +260,7 @@ extensionName = \case LangExt.ListTuplePuns -> "ListTuplePuns" LangExt.MultilineStrings -> "MultilineStrings" LangExt.StringInterpolation -> "StringInterpolation" + LangExt.QualifiedLiterals -> "QualifiedLiterals" LangExt.ExplicitLevelImports -> "ExplicitLevelImports" LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence" ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -868,8 +868,8 @@ ppr_expr (HsOverLabel s l) = case ghcPass @p of ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsInterString _ strType parts) = - char 's' <> delim <> hcat (map pprInterPart parts) <> delim +ppr_expr (HsInterString _ mQualMod strType parts) = + prefix <> delim <> hcat (map pprInterPart parts) <> delim where pprInterPart = \case HsInterStringRaw st s -> @@ -880,6 +880,11 @@ ppr_expr (HsInterString _ strType parts) = (HsStringTypeMulti, NoSourceText) -> pprHsStringMulti' (unpackFS s) HsInterStringExpr _ expr -> text "${" <> ppr_lexpr expr <> text "}" + prefix = + case mQualMod of + Nothing -> char 's' + Just qualMod -> ppr qualMod <> char '.' + delim = case strType of HsStringTypeSingle -> char '"' ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -106,7 +106,7 @@ hsExprType (HsOverLabel v _) = dataConCantHappen v hsExprType (HsIPVar v _) = dataConCantHappen v hsExprType (HsOverLit _ lit) = overLitType lit hsExprType (HsLit _ lit) = hsLitType lit -hsExprType (HsInterString _ _ _) = stringTy -- TODO: handle OverloadedStrings +hsExprType (HsInterString _ _ _ _) = stringTy -- TODO: handle OverloadedStrings + QualifiedLiterals hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -554,7 +554,7 @@ dsExpr (HsOverLabel x _) = dataConCantHappen x dsExpr (OpApp x _ _ _) = dataConCantHappen x dsExpr (SectionL x _ _) = dataConCantHappen x dsExpr (SectionR x _ _) = dataConCantHappen x -dsExpr (HsInterString x _ _) = dataConCantHappen x +dsExpr (HsInterString x _ _ _) = dataConCantHappen x {- ********************************************************************* ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1576,11 +1576,11 @@ repE (HsOverLabel _ s) = repOverLabel s -- HsOverlit can definitely occur repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsInterString _ _ parts) = do +repE (HsInterString _ mQualMod _ parts) = do parts' <- forM parts $ \case HsInterStringRaw _ s -> repInterStringRaw =<< coreStringLit s HsInterStringExpr _ e -> repInterStringExp =<< repLE e - repInterString =<< coreListM interStringPartName parts' + repInterString mQualMod =<< coreListM interStringPartName parts' repE (HsLam _ LamSingle (MG { mg_alts = L _ [m] })) = repLambda m repE e@(HsLam _ LamSingle (MG { mg_alts = L _ _ })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e) repE (HsLam _ LamCase (MG { mg_alts = L _ ms })) @@ -2565,16 +2565,17 @@ repMDoE = repDoBlock mdoEName repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) repDoBlock doName maybeModName (MkC ss) = do - MkC coreModName <- coreModNameM - rep2 doName [coreModName, ss] - where - coreModNameM :: MetaM (Core (Maybe TH.ModName)) - coreModNameM = case maybeModName of - Just m -> do - MkC s <- coreStringLit (moduleNameFS m) - mName <- rep2_nw mkModNameName [s] - coreJust modNameTyConName mName - _ -> coreNothing modNameTyConName + MkC mCoreModName <- repMaybeModName maybeModName + rep2 doName [mCoreModName, ss] + +repMaybeModName :: Maybe ModuleName -> MetaM (Core (Maybe TH.ModName)) +repMaybeModName = \case + Just m -> do + MkC s <- coreStringLit (moduleNameFS m) + mName <- rep2_nw mkModNameName [s] + coreJust modNameTyConName mName + Nothing -> + coreNothing modNameTyConName repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp)) repComp (MkC ss) = rep2 compEName [ss] @@ -2663,8 +2664,10 @@ repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] -------------- Interpolated strings ----------------------------- -repInterString :: Core [M TH.InterStringPart] -> MetaM (Core (M TH.Exp)) -repInterString (MkC parts) = rep2 interStringEName [parts] +repInterString :: Maybe ModuleName -> Core [M TH.InterStringPart] -> MetaM (Core (M TH.Exp)) +repInterString mQualMod (MkC parts) = do + MkC mCoreModName <- repMaybeModName mQualMod + rep2 interStringEName [mCoreModName, parts] repInterStringRaw :: Core String -> MetaM (Core (M TH.InterStringPart)) repInterStringRaw (MkC s) = rep2 interStringRawName [s] ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -477,11 +477,12 @@ addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsInterString x ty parts) = do +addTickHsExpr (HsInterString x mQualMod ty parts) = do + -- TODO: should we add ticks for qualified literals? parts' <- forM parts $ \case part@(HsInterStringRaw {}) -> return part HsInterStringExpr x e -> HsInterStringExpr x <$> addTickLHsExpr e - return $ HsInterString x ty parts' + return $ HsInterString x mQualMod ty parts' addTickHsExpr e@(HsEmbTy {}) = return e addTickHsExpr e@(HsHole {}) = return e addTickHsExpr e@(HsQual {}) = return e ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1198,7 +1198,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where [ toHie (L mspan o) ] HsLit _ _ -> [] - HsInterString _ _ parts -> + HsInterString _ _ _ parts -> [ toHie expr | HsInterStringExpr _ expr <- parts ] ===================================== compiler/GHC/Parser.y ===================================== @@ -736,9 +736,9 @@ are the most common patterns, rewritten as regular expressions for clarity: CHAR { L _ (ITchar _ _) } STRING { L _ (ITstring _ StringTypeSingle _) } STRING_MULTI { L _ (ITstring _ StringTypeMulti _) } - STRING_INTER_BEGIN { L _ (ITstringInterBegin StringTypeSingle) } + STRING_INTER_BEGIN { L _ (ITstringInterBegin _ StringTypeSingle) } STRING_INTER_END { L _ (ITstringInterEnd StringTypeSingle) } - STRING_INTER_MULTI_BEGIN { L _ (ITstringInterBegin StringTypeMulti) } + STRING_INTER_MULTI_BEGIN { L _ (ITstringInterBegin _ StringTypeMulti) } STRING_INTER_MULTI_END { L _ (ITstringInterEnd StringTypeMulti) } STRING_INTER_RAW { L _ (ITstringInterRaw _ _) } STRING_INTER_EXP_OPEN { L _ ITstringInterExpOpen } @@ -4365,7 +4365,7 @@ processStringInter :: processStringInter strType tokBegin parts tokEnd = do parts' <- mapM mkInterStringPartPV $ processRawLexedStrings parts ams1 (L (comb2 tokBegin tokEnd) ()) $ - HsInterString noExtField strType parts' + HsInterString noExtField mQualMod strType parts' where processRawLexedStrings :: [Either (SourceText, RawLexedString) ECP] -> @@ -4379,6 +4379,10 @@ processStringInter strType tokBegin parts tokEnd = do Left (src, s) -> pure $ HsInterStringRaw src (fsLit s) Right (ECP e) -> HsInterStringExpr noExtField <$> runPV e + mQualMod = + let L _ (ITstringInterBegin mMod _) = tokBegin + in mkModuleNameFS <$> mMod + -- Utilities for combining source spans comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan comb2 !a !b = combineHasLocs a b ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -632,6 +632,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } -- See Note [Parsing interpolated strings] and Note [Lexing interpolated strings] <0,string_inter> { s \" / { ifExtension StringInterpolationBit } { string_inter_begin } + @qual \" / { ifExtension QualifiedLiteralsBit } { string_inter_begin } -- TODO(bchinn): interpolated multiline strings } @@ -930,7 +931,9 @@ data Token | ITstring SourceText StringType FastString -- Note [Literal source text] in "GHC.Types.SourceText" -- See Note [Parsing interpolated strings] - | ITstringInterBegin StringType + | ITstringInterBegin + (Maybe FastString) -- Module name, if using QualifiedLiterals + StringType -- Single-line or multiline interpolated string? | ITstringInterRaw SourceText RawLexedString -- Note [Literal source text] in "GHC.Types.SourceText" | ITstringInterExpOpen | ITstringInterExpClose @@ -2196,9 +2199,14 @@ tok_string span buf len _buf2 = do endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' string_inter_begin :: Action -string_inter_begin span _ _ _ = do +string_inter_begin span buf len _ = do pushLexState string_inter_content - pure $ L span (ITstringInterBegin StringTypeSingle) + let mQualMod + | len == 2 = Nothing + | otherwise = + let (qualMod, _) = splitQualName buf len False + in Just qualMod + pure $ L span (ITstringInterBegin mQualMod StringTypeSingle) string_inter_content_action :: Action string_inter_content_action span_init buf_init _ _ = go $ AI (psSpanStart span_init) buf_init @@ -2835,6 +2843,7 @@ data ExtBits | RequiredTypeArgumentsBit | MultilineStringsBit | StringInterpolationBit + | QualifiedLiteralsBit | LevelImportsBit -- Flags that are updated once parsing starts @@ -2920,6 +2929,7 @@ mkParserOpts extensionFlags diag_opts .|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings .|. StringInterpolationBit `xoptBit` LangExt.StringInterpolation + .|. QualifiedLiteralsBit `xoptBit` LangExt.QualifiedLiterals .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports optBits = HaddockBit `setBitIf` isHaddock ===================================== compiler/GHC/Parser/String.hs ===================================== @@ -339,19 +339,19 @@ Interpolated strings are parsed in the following manner: and outputs the following tokens: - [ ITstringInterBegin src StringTypeSingle + [ ITstringInterBegin Nothing StringTypeSingle , ITstringInterRaw src "Hello " - , ITstringInterExpOpen src + , ITstringInterExpOpen , ITqvarid ("Text.toUpper", "name") , ITvarid "name" - , ITstringInterExpClose src + , ITstringInterExpClose , ITstringInterRaw src "!" - , ITstringInterEnd src StringTypeSingle + , ITstringInterEnd StringTypeSingle ] 2. The parser will then parse the tokens into the following HsExpr: - HsInterString ext + HsInterString ext Nothing StringTypeSingle [ HsInterStringRaw ext "Hello " , HsInterStringExp ext $ HsApp ext ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -385,9 +385,9 @@ rnExpr (HsLit x lit) rnExpr (HsOverLit x lit) = rnOverLit x lit -rnExpr (HsInterString _ strType parts) = do +rnExpr (HsInterString _ mQualMod strType parts) = do (parts', fvs1) <- unzip <$> mapM rnInterStringPart parts - (expr, fvs2) <- rewriteInterString strType parts' + (expr, fvs2) <- rewriteInterString mQualMod strType parts' pure (expr, plusFVs fvs1 `plusFV` fvs2) where rnInterStringPart = \case ===================================== compiler/GHC/Rename/String.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Rename.String ( rewriteInterString, @@ -7,24 +9,24 @@ module GHC.Rename.String ( import GHC.Prelude import GHC.Builtin.Names ( - fromBuilderName, interpolateName, - mappendName, - memptyName, - toBuilderName, + mconcatName, ) import GHC.Builtin.Types (stringTyConName) import GHC.Data.FastString (fsLit, unpackFS) import GHC.Hs import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Env (lookupOccRn) import GHC.Rename.Pat (rnOverLit) +import GHC.Tc.Errors.Types (WhatLooking (WL_None)) import GHC.Tc.Utils.Monad +import GHC.Types.Name (Name) +import GHC.Types.Name.Occurrence (mkVarOcc) +import GHC.Types.Name.Reader (mkRdrQual) import GHC.Types.Name.Set (FreeVars, emptyFVs, plusFVs) import GHC.Types.SourceText (SourceText (..)) import GHC.Types.SrcLoc (unLoc) -import qualified Data.List.NonEmpty as NE - {- Note [Desugaring interpolated strings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -34,7 +36,7 @@ Cross-references: Interpolated strings are represented with the following HsExpr tree: - HsInterString ext + HsInterString ext mQualMod strType [ HsInterStringRaw ext "Hello " , HsInterStringExp ext $ HsApp ext @@ -45,12 +47,19 @@ Interpolated strings are represented with the following HsExpr tree: We'll expand this during the renamer phase into the equivalent of: - import GHC.Internal.Data.String.Interpolate + mconcat + [ fromString "Hello " + , interpolate (Text.toUpper name) + , fromString "!" + ] - fromBuilder $ - toBuilder "Hello " - <> interpolate (Text.toUpper name) - <> toBuilder "!" +If using QualifiedLiterals (mQualMod is Just), expand to: + + ModName.fromParts + [ ModName.fromString "Hello " + , ModName.interpolate (Text.toUpper name) + , ModName.fromString "!" + ] We're doing this in the renamer phase so that the expanded expression can be typechecked as usual, without any additional work. @@ -61,42 +70,77 @@ can be typechecked as usual, without any additional work. -- necessary. -- -- TODO(bchinn): allow -XRebindableSyntax -- lookupSyntaxName -rewriteInterString :: HsStringType -> [HsInterStringPart GhcRn] -> RnM (HsExpr GhcRn, FreeVars) -rewriteInterString strType parts = do +rewriteInterString :: + Maybe ModuleName + -> HsStringType + -> [HsInterStringPart GhcRn] + -> RnM (HsExpr GhcRn, FreeVars) +rewriteInterString mQualMod strType parts = do overloaded <- xoptM LangExt.OverloadedStrings - (parts', fvs) <- unzip <$> mapM (rewritePart overloaded) parts + mQualNames <- traverse lookupQualifiedLiteralStringsNames mQualMod + rewriteInterStringImpl overloaded mQualNames strType parts + +rewriteInterStringImpl :: + Bool + -> Maybe QualifiedLiteralStringsNames + -> HsStringType + -> [HsInterStringPart GhcRn] + -> RnM (HsExpr GhcRn, FreeVars) +rewriteInterStringImpl overloaded mQualNames strType parts = do + (parts', fvs) <- unzip <$> mapM rewritePart parts let expr = - (if overloaded then id else addSig) . nlHsApp (nlHsVar fromBuilderName) $ - maybe (nlHsVar memptyName) (foldr1 appendParts) (NE.nonEmpty parts') + addSig + . (nlHsApp $ nlHsVar $ maybe mconcatName qualFromParts mQualNames) + $ noLocA (ExplicitList noExtField parts') pure (unLoc expr, plusFVs fvs) where - appendParts l r = nlHsApps mappendName [l, r] - rewritePart overloaded = \case - HsInterStringRaw _ s -> do - (lit, fvs) <- mkStringLit overloaded s - pure (nlHsApps toBuilderName [lit], fvs) - HsInterStringExpr _ e -> - pure (nlHsApps interpolateName [e], emptyFVs) - - -- Add ":: String" to the given expression - addSig e = - noLocA . ExprWithTySig noExtField e $ - HsWC - { hswc_ext = [] - , hswc_body = - noLocA - HsSig - { sig_ext = noExtField - , sig_bndrs = HsOuterImplicit [] - , sig_body = nlHsTyVar NotPromoted stringTyConName - } - } - - mkStringLit overloaded s = do + rewritePart = \case + HsInterStringRaw _ s -> mkStringLit s + HsInterStringExpr _ e -> do + let interpolateName' = maybe interpolateName qualInterpolate mQualNames + pure (nlHsApp (nlHsVar interpolateName') e, emptyFVs) + + addSig e + | Just _ <- mQualNames = e + | overloaded = e + | otherwise = + -- explicitly add ":: String" if not overloaded + noLocA . ExprWithTySig noExtField e $ + HsWC + { hswc_ext = [] + , hswc_body = + noLocA + HsSig + { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit [] + , sig_body = nlHsTyVar NotPromoted stringTyConName + } + } + + mkStringLit s = do let src = SourceText $ fsLit $ "\"" ++ unpackFS s ++ "\"" - if overloaded - then do - (expr, fvs) <- rnOverLit noExtField $ OverLit noExtField (HsIsString src s) - pure (noLocA expr, fvs) - else - pure (nlHsLit $ HsString src strType s, emptyFVs) + let lit = nlHsLit $ HsString src strType s + if + | Just qualNames <- mQualNames -> do + pure (nlHsApp (nlHsVar $ qualFromString qualNames) lit, emptyFVs) + | overloaded -> do + (expr, fvs) <- rnOverLit noExtField $ OverLit noExtField (HsIsString src s) + pure (noLocA expr, fvs) + | otherwise -> do + pure (lit, emptyFVs) + +data QualifiedLiteralStringsNames = QualifiedLiteralStringsNames + { qualFromString :: Name + , qualInterpolate :: Name + , qualFromParts :: Name + } + +lookupQualifiedLiteralStringsNames :: + ModuleName -> RnM QualifiedLiteralStringsNames +lookupQualifiedLiteralStringsNames modName = do + qualFromString <- lookup "fromString" + qualInterpolate <- lookup "interpolate" + qualFromParts <- lookup "fromParts" + pure QualifiedLiteralStringsNames{..} + where + lookup = lookupOccRn WL_None . mkRdrQual modName . mkVarOcc ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -727,7 +727,7 @@ exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsInterString _ _ _) = InterStringOrigin +exprCtOrigin (HsInterString _ _ _ _) = InterStringOrigin exprCtOrigin (HsLam _ _ ms) = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -955,7 +955,7 @@ zonkExpr (HsOverLit x lit) = do { lit' <- zonkOverLit lit ; return (HsOverLit x lit') } -zonkExpr (HsInterString x _ _) = dataConCantHappen x +zonkExpr (HsInterString x _ _ _) = dataConCantHappen x zonkExpr (HsLam x lam_variant matches) = do new_matches <- zonkMatchGroup zonkLExpr matches ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1226,11 +1226,12 @@ cvtl e = wrapLA (cvt e) ; let tele = setTelescopeBndrsNameSpace varName $ mkHsForAllVisTele noAnn tvs' ; return $ HsForAll noExtField tele body' } - cvt (InterStringE parts) = do + cvt (InterStringE mQualMod parts) = do + let mQualMod' = mk_mod <$> mQualMod parts' <- forM parts $ \case InterStringRaw s -> pure $ HsInterStringRaw (SourceText $ fsLit s) (fsLit s) InterStringExp e -> HsInterStringExpr noExtField <$> cvtl e - return $ HsInterString noExtField HsStringTypeSingle parts' + return $ HsInterString noExtField mQualMod' HsStringTypeSingle parts' {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -349,6 +349,7 @@ data HsExpr p | -- | See Note [Parsing interpolated strings] HsInterString (XInterString p) + (Maybe ModuleName) -- ^ Module, if using QualifiedLiterals HsStringType [HsInterStringPart p] ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -250,9 +250,13 @@ pprExp i (ForallE tvars body) = pprExp i (ConstrainedE ctx body) = parensIf (i >= funPrec) $ sep [pprCtxWith pprExp ctx, pprExp qualPrec body] -pprExp _ (InterStringE parts) = - text "s\""<> hcat (map pprInterStringPart parts) <> text "\"" +pprExp _ (InterStringE mQualMod parts) = + prefix <> char '"' <> hcat (map pprInterStringPart parts) <> char '"' where + prefix = + case mQualMod of + Nothing -> char 's' + Just qualMod -> text (modString qualMod) <> char '.' pprInterStringPart = \case InterStringRaw s -> text s InterStringExp e -> text "${" <> pprExp noPrec e <> text "}" ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs ===================================== @@ -15,11 +15,7 @@ See the proposal for motivation and explanations: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0570-st... -} module Data.String.Interpolate.Experimental ( - Buildable (..), Interpolate (..), - - -- * Built-in builders - StringBuilder (..), ) where import GHC.Internal.Data.String.Interpolate ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs ===================================== @@ -20,62 +20,66 @@ ----------------------------------------------------------------------------- module GHC.Internal.Data.String.Interpolate ( - Buildable (..), Interpolate (..), - - -- * Built-in builders - StringBuilder (..), ) where import GHC.Internal.Base -import GHC.Internal.Data.Monoid (Endo (..)) -import GHC.Internal.Show (Show, shows) - --- | @Buildable s@ allows @s@ to be built from an interpolated string. --- --- Laws: --- * @fromBuilder . toBuilder === id@ --- * @toBuilder . fromBuilder === id@ -class Monoid (Builder s) => Buildable s where - type Builder s = r | r -> s - toBuilder :: s -> Builder s - fromBuilder :: Builder s -> s +import GHC.Internal.Data.Either (Either (..)) +import GHC.Internal.Data.List (intercalate) +import GHC.Internal.Show (show) -- | @Interpolate a s@ allows a value of type @a@ to be interpolated -- into a string interpolation of type @s@. --- --- Laws: --- * @interpolate \@s \@s = toBuilder@ --- * @interpolate \@(Builder s) \@s = id@ -class Buildable s => Interpolate a s where - interpolate :: a -> Builder s - -newtype StringBuilder = StringBuilder (Endo String) - deriving newtype (Semigroup, Monoid) - -instance Buildable String where - type Builder String = StringBuilder - toBuilder = toStringBuilder - fromBuilder = fromStringBuilder - -{-# RULES -"fromStringBuilder/toStringBuilder" forall s. fromStringBuilder (toStringBuilder s) = s -"toStringBuilder/fromStringBuilder" forall s. toStringBuilder (fromStringBuilder s) = s - #-} - -toStringBuilder :: String -> StringBuilder -toStringBuilder s = StringBuilder (Endo (s ++)) -{-# NOINLINE [2] toStringBuilder #-} - -fromStringBuilder :: StringBuilder -> String -fromStringBuilder (StringBuilder (Endo f)) = f "" -{-# NOINLINE [2] fromStringBuilder #-} +class Interpolate a s where + interpolate :: a -> s instance Interpolate String String where - interpolate = toBuilder -instance Interpolate StringBuilder String where interpolate = id instance Interpolate Char String where interpolate = interpolate . (:[]) -instance {-# OVERLAPPABLE #-} Show a => Interpolate a String where - interpolate = StringBuilder . Endo . shows + +instance Interpolate Int String where + interpolate = show +instance Interpolate Double String where + interpolate = show +instance Interpolate Bool String where + interpolate = show + +instance {-# OVERLAPPABLE #-} + ( Interpolate a String + ) => Interpolate [a] String where + interpolate as = "[" ++ (intercalate ", " . map interpolate) as ++ "]" +instance + ( Interpolate a String + , Interpolate b String + ) => Interpolate (Either a b) String where + interpolate (Left a) = "Left " ++ interpolate a + interpolate (Right b) = "Right " ++ interpolate b + +instance + ( Interpolate a String + , Interpolate b String + ) => Interpolate (a, b) String where + interpolate (a, b) = + mconcat + [ "(" + , interpolate a + , ", " + , interpolate b + , ")" + ] +instance + ( Interpolate a String + , Interpolate b String + , Interpolate c String + ) => Interpolate (a, b, c) String where + interpolate (a, b, c) = + mconcat + [ "(" + , interpolate a + , ", " + , interpolate b + , ", " + , interpolate c + , ")" + ] ===================================== libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs ===================================== @@ -166,6 +166,7 @@ data Extension | ListTuplePuns | MultilineStrings | StringInterpolation + | QualifiedLiterals | ExplicitLevelImports | ImplicitStagePersistence deriving (Eq, Enum, Show, Generic, Bounded) ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -450,8 +450,8 @@ forallVisE tvars body = ForallVisE <$> sequenceA tvars <*> body constrainedE :: Quote m => [m Exp] -> m Exp -> m Exp constrainedE ctx body = ConstrainedE <$> sequenceA ctx <*> body -interStringE :: Quote m => [m InterStringPart] -> m Exp -interStringE parts = InterStringE <$> sequenceA parts +interStringE :: Quote m => Maybe ModName -> [m InterStringPart] -> m Exp +interStringE mQualMod parts = InterStringE mQualMod <$> sequenceA parts ------------------------------------------------------------------------------- -- * Dec ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -1903,7 +1903,9 @@ data Exp | ForallE [TyVarBndr Specificity] Exp -- ^ @forall \. \@ | ForallVisE [TyVarBndr ()] Exp -- ^ @forall \ -> \@ | ConstrainedE [Exp] Exp -- ^ @\ => \@ - | InterStringE [InterStringPart] -- ^ @{ s"Name: ${personName}" }@ + | InterStringE -- ^ @{ s"Name: ${personName}" }@ or @{ Mod."A ${x}" }@ + (Maybe ModName) + [InterStringPart] deriving( Show, Eq, Ord, Data, Generic ) -- | A (field name, expression) pair. See 'RecConE' and 'RecUpdE'. ===================================== testsuite/tests/driver/T4437.hs ===================================== @@ -36,7 +36,7 @@ check title expected got -- See Note [Adding a language extension] in compiler/GHC/Driver/Session.hs. expectedGhcOnlyExtensions :: [String] -expectedGhcOnlyExtensions = [ "StringInterpolation" ] +expectedGhcOnlyExtensions = [ "StringInterpolation", "QualifiedLiterals" ] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", ===================================== testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs ===================================== @@ -1,5 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE MultilineStrings #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -77,17 +75,9 @@ data SqlValue | SqlInt Int deriving (Show) -newtype SqlQueryBuilder = SqlQueryBuilder (Endo SqlQuery) - deriving newtype (Semigroup, Monoid) - -instance Buildable SqlQuery where - type Builder SqlQuery = SqlQueryBuilder - toBuilder q = SqlQueryBuilder (Endo (q <>)) - fromBuilder (SqlQueryBuilder (Endo f)) = f mempty - instance Interpolate SqlQuery SqlQuery where - interpolate = toBuilder + interpolate = id instance Interpolate String SqlQuery where - interpolate s = toBuilder SqlQuery{sqlText = "?", sqlValues = [SqlString s]} + interpolate s = SqlQuery{sqlText = "?", sqlValues = [SqlString s]} instance Interpolate Int SqlQuery where - interpolate x = toBuilder SqlQuery{sqlText = "?", sqlValues = [SqlInt x]} + interpolate x = SqlQuery{sqlText = "?", sqlValues = [SqlInt x]} ===================================== testsuite/tests/parser/should_run/StringInterpolationQualified.hs ===================================== @@ -0,0 +1,44 @@ +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE QualifiedLiterals #-} +{-# LANGUAGE RecordWildCards #-} + +import qualified StringInterpolationQualified_SQL as SQL + +main :: IO () +main = mapM_ runTest allTests + +data TestCase = + forall a. Show a => + TestCase + { label :: String + , expression :: a + } + +runTest :: TestCase -> IO () +runTest TestCase{..} = do + putStrLn $ "****************************************" + putStrLn $ "Input:" + putStr $ unlines . map (" " ++) . lines $ label + putStrLn $ "====>" + putStrLn $ " " ++ show expression + +allTests :: [TestCase] +allTests = + [ TestCase -- custom interpolation implementations + { label = + """ + let + name = "'Robert'; DROP TABLE Students;--" + age = 10 :: Int + in + SQL."SELECT * FROM tab WHERE name ILIKE ${name} and age = ${age}" + """ + , expression = + let + name = "'Robert'; DROP TABLE Students;--" + age = 10 :: Int + in + SQL."SELECT * FROM tab WHERE name ILIKE ${name} and age = ${age}" + } + -- TODO(bchinn): qualified interpolated multiline string + ] ===================================== testsuite/tests/parser/should_run/StringInterpolationQualified.stdout ===================================== @@ -0,0 +1,9 @@ +**************************************** +Input: + let + name = "'Robert'; DROP TABLE Students;--" + age = 10 :: Int + in + SQL."SELECT * FROM tab WHERE name ILIKE ${name} and age = ${age}" +====> + SqlQuery {sqlText = "SELECT * FROM tab WHERE name ILIKE ? and age = ?", sqlValues = [SqlString "'Robert'; DROP TABLE Students;--",SqlInt 10]} ===================================== testsuite/tests/parser/should_run/StringInterpolationQualified_SQL.hs ===================================== @@ -0,0 +1,47 @@ +module StringInterpolationQualified_SQL where + +import qualified Data.String + +data SqlQuery = SqlQuery + { sqlText :: String + , sqlValues :: [SqlValue] + } + deriving (Show) + +instance Data.String.IsString SqlQuery where + fromString s = SqlQuery{sqlText = s, sqlValues = []} +instance Semigroup SqlQuery where + q1 <> q2 = + SqlQuery + { sqlText = sqlText q1 <> sqlText q2 + , sqlValues = sqlValues q1 <> sqlValues q2 + } +instance Monoid SqlQuery where + mempty = + SqlQuery + { sqlText = "" + , sqlValues = [] + } + +data SqlValue + = SqlString String + | SqlInt Int + deriving (Show) + +class ToSqlValue a where + toSqlValue :: a -> SqlValue +instance ToSqlValue String where + toSqlValue = SqlString +instance ToSqlValue Int where + toSqlValue = SqlInt + +{----- QualifiedLiterals -----} + +fromString :: String -> SqlQuery +fromString = Data.String.fromString + +interpolate :: ToSqlValue a => a -> SqlQuery +interpolate v = SqlQuery{sqlText = "?", sqlValues = [toSqlValue v]} + +fromParts :: [SqlQuery] -> SqlQuery +fromParts = mconcat ===================================== testsuite/tests/parser/should_run/all.T ===================================== @@ -38,3 +38,4 @@ test('T25784', normal, compile_and_run, ['']) # String interpolation test('StringInterpolation', normal, compile_and_run, ['']) test('StringInterpolationOverloaded', normal, compile_and_run, ['']) +test('StringInterpolationQualified', [extra_files(['StringInterpolationQualified_SQL.hs'])], multimod_compile_and_run, ['StringInterpolationQualified', '']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d114d7ddd044760d1494c2e65c752264... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d114d7ddd044760d1494c2e65c752264... You're receiving this email because of your account on gitlab.haskell.org.