Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: a9f7a933 by Brandon Chinn at 2026-05-25T11:07:05-07:00 [ci skip] wip - - - - - 9 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Rename/String.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/Data/String/Interpolate/Basic/Experimental.hs - libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs - testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs - testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout - testsuite/tests/qualified-strings/should_run/Example/SQL.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -282,7 +282,11 @@ basicKnownKeyNames fromStringName, -- Interpolated strings - interpolateStringName, + interpolateRawName, + interpolateValueName, + interpolateAppendName, + interpolateEmptyName, + interpolateFinalizeName, -- Enum stuff enumFromName, enumFromThenName, @@ -1090,8 +1094,17 @@ minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpK negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey -- Module GHC.Internal.Data.String.Interpolate -interpolateStringName :: Name -interpolateStringName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateString") interpolateStringKey +interpolateRawName + , interpolateValueName + , interpolateAppendName + , interpolateEmptyName + , interpolateFinalizeName + :: Name +interpolateRawName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateRaw" ) interpolateRawKey +interpolateValueName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateValue" ) interpolateValueKey +interpolateAppendName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateAppend" ) interpolateAppendKey +interpolateEmptyName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateEmpty" ) interpolateEmptyKey +interpolateFinalizeName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateFinalize") interpolateFinalizeKey --------------------------------- -- ghc-bignum @@ -2392,8 +2405,17 @@ proxyHashKey :: Unique proxyHashKey = mkPreludeMiscIdUnique 502 -- String interpolation -interpolateStringKey :: Unique -interpolateStringKey = mkPreludeMiscIdUnique 576 +interpolateRawKey + , interpolateValueKey + , interpolateAppendKey + , interpolateEmptyKey + , interpolateFinalizeKey + :: Unique +interpolateRawKey = mkPreludeMiscIdUnique 576 +interpolateValueKey = mkPreludeMiscIdUnique 577 +interpolateAppendKey = mkPreludeMiscIdUnique 578 +interpolateEmptyKey = mkPreludeMiscIdUnique 579 +interpolateFinalizeKey = mkPreludeMiscIdUnique 580 ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES IdUniques 200-499 ===================================== compiler/GHC/Rename/String.hs ===================================== @@ -8,14 +8,12 @@ import GHC.Prelude import Data.Maybe (isNothing) import qualified GHC.Builtin.Names as Builtin -import GHC.Builtin.Types (stringTyConName) import GHC.Data.StringMeta (StringMeta (..)) import GHC.Hs import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Env (lookupNameWithQualifier) -import GHC.Rename.Pat (rnOverLit) +import GHC.Rename.Env (lookupNameWithQualifier, lookupSyntaxName) import GHC.Tc.Utils.Monad -import GHC.Types.Name (mkVarOcc) +import GHC.Types.Name (Name) import GHC.Types.Name.Set (FreeNames, emptyFNs, plusFNs) import GHC.Types.SrcLoc (unLoc) @@ -59,58 +57,46 @@ rewriteInterString :: [HsInterStringPart GhcRn] -> RnM (HsExpr GhcRn, FreeNames) rewriteInterString meta parts = do - overloaded <- xoptM LangExt.OverloadedStrings - convertName <- newName (mkVarOcc "convert") - rawName <- newName (mkVarOcc "raw") - mappendName <- newName (mkVarOcc "mappend") - memptyName <- newName (mkVarOcc "mempty") - - (interpolateStringName, fvs1) <- - case strMetaQualified meta of - Just modName -> lookupNameWithQualifier Builtin.interpolateStringName modName - Nothing -> pure (Builtin.interpolateStringName, emptyFNs) - (parts', fvs2) <- unzip <$> mapM (rewritePart overloaded convertName rawName) parts + mkOverloaded <- get_mkOverloaded + + let lookupName' = lookupName (strMetaQualified meta) + (rawName, fns1) <- lookupName' Builtin.interpolateRawName + (convertName, fns2) <- lookupName' Builtin.interpolateValueName + (appendName, fns3) <- lookupName' Builtin.interpolateAppendName + (emptyName, fns4) <- lookupName' Builtin.interpolateEmptyName + (finalizeName, fns5) <- lookupName' Builtin.interpolateFinalizeName + let expr = - (if not overloaded && isNothing (strMetaQualified meta) then addSig else id) - . nlHsApp (nlHsVar interpolateStringName) - . mkLam - [ nlVarPat convertName - , nlVarPat rawName - , nlVarPat mappendName - , nlVarPat memptyName - ] - $ foldr (\p acc -> nlHsApps mappendName [p, acc]) (nlHsVar memptyName) parts' - - pure (unLoc expr, plusFNs $ [fvs1] ++ fvs2) + unLoc + . mkOverloaded + . nlHsApp (nlHsVar finalizeName) + . foldr (\p acc -> nlHsApps appendName [p, acc]) (nlHsVar emptyName) + $ map (rewritePart convertName rawName) parts + + pure (expr, plusFNs [fns1, fns2, fns3, fns4, fns5]) where - mkLam pats body = mkHsLam (noLocA pats) body - - rewritePart overloaded convertName rawName = \case - HsInterStringRaw st s -> do - (lit, fvs) <- mkStringLit overloaded st s - pure (nlHsApps rawName [lit], fvs) - HsInterStringExpr _ e -> - pure (nlHsApps convertName [e], emptyFNs) - - -- 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 st s = do - if overloaded - then do - -- FIXME(bchinn): allow -XRebindableSyntax -- lookupSyntaxName - (expr, fvs) <- rnOverLit noExtField $ OverLit noExtField (HsIsString st s) - pure (noLocA expr, fvs) - else - pure (nlHsLit $ HsString st s, emptyFNs) + rewritePart convertName rawName = \case + HsInterStringRaw st s -> nlHsApps rawName [nlHsLit $ HsString st s] + HsInterStringExpr _ e -> nlHsApps convertName [e] + + -- Handle -XOverloadedStrings + get_mkOverloaded = do + overloaded <- xoptM LangExt.OverloadedStrings + pure $ + if overloaded && isNothing (strMetaQualified meta) + then nlHsApp (nlHsVar Builtin.fromStringName) + else id + +-- | Look up the given name in the following places: +-- 1. If the given module is provided, in the module +-- 2. If -XRebindableSyntax, any name in scope +-- 3. Otherwise, return the built-in name. +lookupName :: Maybe ModuleName -> Name -> RnM (Name, FreeNames) +lookupName mQualMod name + | Just mod <- mQualMod = + lookupNameWithQualifier name mod + | otherwise = do + isRebindable <- xoptM LangExt.RebindableSyntax + if isRebindable + then lookupSyntaxName name + else pure (name, emptyFNs) ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -34,6 +34,7 @@ library import: warnings exposed-modules: Data.String.Interpolate.Experimental + Data.String.Interpolate.Basic.Experimental Data.Sum.Experimental Data.Tuple.Experimental GHC.PrimOps ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Basic/Experimental.hs ===================================== @@ -0,0 +1,18 @@ +module Data.String.Interpolate.Basic.Experimental where + +import Data.String (IsString (..)) + +interpolateRaw :: IsString s => String -> s +interpolateRaw = fromString + +interpolateValue :: s -> s +interpolateValue = id + +interpolateAppend :: Monoid s => s -> s -> s +interpolateAppend = mappend + +interpolateEmpty :: Monoid s => s +interpolateEmpty = mempty + +interpolateFinalize :: s -> s +interpolateFinalize = id ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs ===================================== @@ -14,8 +14,13 @@ See the proposal for motivation and explanations: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0570-st... -} module Data.String.Interpolate.Experimental ( - SimpleStringInterpolator, - interpolateString, + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, + + -- * Interpolate class Interpolate (..), ) where ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs ===================================== @@ -12,57 +12,73 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} module GHC.Internal.Data.String.Interpolate ( - SimpleStringInterpolator, - interpolateString, + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, + + -- * StringBuilder + StringBuilder (..), + buildString, + + -- * Interpolate class Interpolate (..), ) where import GHC.Internal.Base -import GHC.Internal.Data.Maybe (Maybe (..)) +import GHC.Internal.Data.Monoid (Endo (..)) import GHC.Internal.Data.String (IsString, fromString) -import GHC.Internal.Show (ShowS, showChar, showString, shows) +import GHC.Internal.Show (show) import GHC.Internal.Types -type SimpleStringInterpolator s = - ( forall ss. - (forall a. Interpolate a => a -> s) - -> (s -> s) - -> (s -> ss -> ss) - -> ss - -> ss - ) - -> s +interpolateRaw :: String -> StringBuilder +interpolateRaw = fromString -interpolateString :: (IsString s, Monoid s) => SimpleStringInterpolator s -interpolateString f = mconcat $ f (fromString . interpolate) id (:) [] -{-# INLINE interpolateString #-} +interpolateValue :: Interpolate a => a -> StringBuilder +interpolateValue = interpolate -class Interpolate a where - {-# MINIMAL interpolate | interpolateS #-} +interpolateAppend :: StringBuilder -> StringBuilder -> StringBuilder +interpolateAppend = mappend - interpolate :: a -> String - interpolate x = interpolateS x "" +interpolateEmpty :: StringBuilder +interpolateEmpty = mempty - interpolateS :: a -> ShowS - interpolateS x s = interpolate x <> s +interpolateFinalize :: StringBuilder -> String +interpolateFinalize = buildString -instance Interpolate String where - interpolateS = showString -instance Interpolate Char where - interpolateS = showChar +{----- StringBuilder -----} + +newtype StringBuilder = StringBuilder (Endo String) + deriving newtype (Semigroup, Monoid) +instance IsString StringBuilder where + fromString s = StringBuilder (Endo (s <>)) -#define INTERPOLATE_WITH_SHOW(x) \ - instance Interpolate x where \ - interpolateS = shows -INTERPOLATE_WITH_SHOW(Int) -INTERPOLATE_WITH_SHOW(Double) -INTERPOLATE_WITH_SHOW(Bool) --- FIXME(bchinn): More instances +buildString :: StringBuilder -> String +buildString (StringBuilder (Endo f)) = f "" -instance Interpolate a => Interpolate (Maybe a) where - interpolateS Nothing = showString "Nothing" - interpolateS (Just a) = showString "Just (" . interpolateS a . showChar ')' +{---- Interpolate ----} + +class Interpolate a where + interpolate :: (IsString s, Monoid s) => a -> s + +instance Interpolate String where + interpolate = fromString +instance Interpolate Char where + interpolate c = fromString [c] +instance Interpolate Int where + interpolate = interpolate . show +instance Interpolate Double where + interpolate = interpolate . show +instance Interpolate Bool where + interpolate = interpolate . show ===================================== testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs ===================================== @@ -2,10 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StringInterpolation #-} +{-# LANGUAGE TypeFamilies #-} import Data.String.Interpolate.Experimental import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.Lazy.Builder qualified as LazyText +import Data.Text.Lazy.Builder.Int qualified as LazyText +import Data.Text.Lazy.Builder.RealFloat qualified as LazyText +import Data.Text.Lazy qualified as LazyText main :: IO () main = mapM_ runTest allTests @@ -30,14 +35,14 @@ allTests = [ TestCase -- Text { label = """ - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text """ , expression = - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text } -- FIXME(bchinn): overloaded interpolated multiline string ] -- Remove when text provides this instance instance Interpolate Text where - interpolateS = interpolateS . Text.unpack + interpolate = interpolate . Text.unpack ===================================== testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout ===================================== @@ -1,5 +1,5 @@ **************************************** Input: - let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text + let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text ====> "world hello world True" ===================================== testsuite/tests/qualified-strings/should_run/Example/SQL.hs ===================================== @@ -1,7 +1,13 @@ module Example.SQL ( SqlQuery (..), SqlValue (..), - interpolateString, + + -- * String interpolation + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, ) where import Data.String (IsString (..)) @@ -41,12 +47,17 @@ instance ToSqlQuery String where instance ToSqlQuery Int where toSqlQuery x = SqlQuery{sqlText = "?", sqlValues = [SqlInt x]} -interpolateString :: - ( (forall a. ToSqlQuery a => a -> SqlQuery) -> - (String -> SqlQuery) -> - (SqlQuery -> SqlQuery -> SqlQuery) -> - SqlQuery -> - SqlQuery - ) -> - SqlQuery -interpolateString f = f toSqlQuery fromString (<>) mempty +interpolateRaw :: String -> SqlQuery +interpolateRaw = fromString + +interpolateValue :: ToSqlQuery a => a -> SqlQuery +interpolateValue = toSqlQuery + +interpolateAppend :: SqlQuery -> SqlQuery -> SqlQuery +interpolateAppend = mappend + +interpolateEmpty :: SqlQuery +interpolateEmpty = mempty + +interpolateFinalize :: SqlQuery -> SqlQuery +interpolateFinalize = id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9f7a933cfe9f88ac10ab189acc447b9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9f7a933cfe9f88ac10ab189acc447b9... You're receiving this email because of your account on gitlab.haskell.org.