- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/az/T27294-modifier-semis
by Alan Zimmerman (＠alanz) 25 May '26

25 May '26

Alan Zimmerman pushed new branch wip/az/T27294-modifier-semis at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/T27294-modifier-semis You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] wasm: ensure post-linker output is synchronous ESM
by Marge Bot (＠marge-bot) 25 May '26

25 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cccf45da by Cheng Shao at 2026-05-25T16:32:13-04:00 wasm: ensure post-linker output is synchronous ESM This patch fixes wasm backend's post-linker output script to ensure it's synchronous ESM and doesn't use top-level await, which doesn't work in ServiceWorkers. Fixes #27257. - - - - - 2 changed files: - + changelog.d/wasm-fix-serviceworker - utils/jsffi/prelude.mjs Changes: ===================================== changelog.d/wasm-fix-serviceworker ===================================== @@ -0,0 +1,4 @@ +section: wasm-backend +synopsis: Ensure post-linker output is synchronous ESM and fix loading in ServiceWorker +issues: #27257 +mrs: !16093 ===================================== utils/jsffi/prelude.mjs ===================================== @@ -39,19 +39,13 @@ export class JSValManager { // To benchmark different setImmediate() implementations in the // browser, use https://github.com/jphpsf/setImmediate-shim-demo as a // starting point. -export const setImmediate = await (async () => { - // node, bun, or other scripts might have set this up in the browser +export const setImmediate = (() => { + // node, deno, bun, or other scripts might have set this up in the + // browser if (globalThis.setImmediate) { return globalThis.setImmediate; } - // deno - if (globalThis.Deno) { - try { - return (await import("node:timers")).setImmediate; - } catch {} - } - // https://developer.mozilla.org/en-US/docs/Web/API/Scheduler/postTask if (globalThis.scheduler) { return (cb, ...args) => scheduler.postTask(() => cb(...args)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cccf45da01988801b0c97f7e7ed0160… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cccf45da01988801b0c97f7e7ed0160… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/interpolated-strings] [ci skip] wip
by Brandon Chinn (＠brandonchinn178) 25 May '26

25 May '26

Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: 82274ff5 by Brandon Chinn at 2026-05-25T13:32:44-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,23 @@ +module Data.String.Interpolate.Basic.Experimental where + +import Data.String (IsString (..)) + +interpolateRaw :: IsString s => String -> s +interpolateRaw = fromString +{-# INLINE [1] interpolateRaw #-} + +interpolateValue :: s -> s +interpolateValue = id +{-# INLINE [1] interpolateValue #-} + +interpolateAppend :: Monoid s => s -> s -> s +interpolateAppend = mappend +{-# INLINE [1] interpolateAppend #-} + +interpolateEmpty :: Monoid s => s +interpolateEmpty = mempty +{-# INLINE [1] interpolateEmpty #-} + +interpolateFinalize :: s -> s +interpolateFinalize = id +{-# INLINE [1] interpolateFinalize #-} ===================================== 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-s… -} 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,85 @@ -- ----------------------------------------------------------------------------- {-# 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 +{-# INLINE [1] interpolateRaw #-} -interpolateString :: (IsString s, Monoid s) => SimpleStringInterpolator s -interpolateString f = mconcat $ f (fromString . interpolate) id (:) [] -{-# INLINE interpolateString #-} +interpolateValue :: Interpolate a => a -> StringBuilder +interpolateValue = interpolate +{-# INLINE [1] interpolateValue #-} -class Interpolate a where - {-# MINIMAL interpolate | interpolateS #-} +interpolateAppend :: StringBuilder -> StringBuilder -> StringBuilder +interpolateAppend = mappend +{-# INLINE [1] interpolateAppend #-} - interpolate :: a -> String - interpolate x = interpolateS x "" +interpolateEmpty :: StringBuilder +interpolateEmpty = mempty +{-# INLINE [1] interpolateEmpty #-} - interpolateS :: a -> ShowS - interpolateS x s = interpolate x <> s +interpolateFinalize :: StringBuilder -> String +interpolateFinalize = buildString +{-# INLINE [1] interpolateFinalize #-} -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 <>)) + {-# INLINE [1] fromString #-} -#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 "" +{-# INLINE [1] buildString #-} -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 + {-# INLINE [1] interpolate #-} +instance Interpolate Char where + interpolate c = fromString [c] + {-# INLINE [1] interpolate #-} +instance Interpolate Int where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} +instance Interpolate Double where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} +instance Interpolate Bool where + interpolate = fromString . show + {-# INLINE [1] interpolate #-} ===================================== 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/82274ff589c2b9ce56a55ae068005a4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82274ff589c2b9ce56a55ae068005a4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Ensure that SetOps.{minusList,unionListsOrd} can be specialized
by Marge Bot (＠marge-bot) 25 May '26

25 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 579aa0b7 by Simon Jakobi at 2026-05-25T16:31:26-04:00 Ensure that SetOps.{minusList,unionListsOrd} can be specialized ...by marking them INLINABLE. Haddock allocates 0.1–0.3% less as a result. This also removes some redundant constraints on unionListsOrd. - - - - - 1 changed file: - compiler/GHC/Data/List/SetOps.hs Changes: ===================================== compiler/GHC/Data/List/SetOps.hs ===================================== @@ -60,12 +60,13 @@ getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $ -- -- Uses a set internally to record duplicates. This makes it slightly slower for -- very small lists but avoids quadratic behaviour for large lists. -unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a] +unionListsOrd :: Ord a => [a] -> [a] -> [a] unionListsOrd xs ys - -- Since both arguments don't have internal duplicates we can just take all of xs - -- and every element of ys that's not already in xs. + -- Since both arguments don't have internal duplicates we can just take all of ys + -- and every element of xs that's not already in ys. = let set_ys = S.fromList ys in (filter (\e -> not $ S.member e set_ys) xs) ++ ys +{-# INLINABLE unionListsOrd #-} -- Ensure the function can be specialized. -- | Assumes that the arguments contain no duplicates unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] @@ -108,6 +109,7 @@ minusList xs [y] = filter (/= y) xs minusList xs ys = filter (`S.notMember` yss) xs where yss = S.fromList ys +{-# INLINABLE minusList #-} -- Ensure the function can be specialized. {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/579aa0b7b8ec4fcfde2edcf1c43e51d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/579aa0b7b8ec4fcfde2edcf1c43e51d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/interpolated-strings] [ci skip] wip
by Brandon Chinn (＠brandonchinn178) 25 May '26

25 May '26

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-s… -} 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/a9f7a933cfe9f88ac10ab189acc447b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9f7a933cfe9f88ac10ab189acc447b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/interpolated-strings] [ci skip] wip
by Brandon Chinn (＠brandonchinn178) 25 May '26

25 May '26

Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC Commits: 8e984032 by Brandon Chinn at 2026-05-25T11:02:14-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/Experimental.hs - + libraries/ghc-experimental/src/Data/String/Interpolate/Explicit/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.Explicit.Experimental Data.Sum.Experimental Data.Tuple.Experimental GHC.PrimOps ===================================== 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-s… -} module Data.String.Interpolate.Experimental ( - SimpleStringInterpolator, - interpolateString, + interpolateRaw, + interpolateValue, + interpolateAppend, + interpolateEmpty, + interpolateFinalize, + + -- * Interpolate class Interpolate (..), ) where ===================================== libraries/ghc-experimental/src/Data/String/Interpolate/Explicit/Experimental.hs ===================================== @@ -0,0 +1,18 @@ +module Data.String.Interpolate.Explicit.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-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/8e9840327eea2d9ca491fa123f68886… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e9840327eea2d9ca491fa123f68886… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/multi-caret] Add support for related locations in Diagnostic
by Simon Jakobi (＠sjakobi2) 25 May '26

25 May '26

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: e2180816 by Simon Jakobi at 2026-05-25T17:51:00+02:00 Add support for related locations in Diagnostic * Convert TcRnBindingNameConflict to demonstrate this feature. * Enable -fdiagnostics-show-caret in some tests to show what error messages with multiple caret sections look like. This prepares the ground for #22637. The diagnosticRelatedLocations name is inspired by #23414. - - - - - 12 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - testsuite/tests/patsyn/should_fail/T14114.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rename/should_fail/rnfail004.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail038.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -15,6 +15,7 @@ import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger +import Data.List.NonEmpty (NonEmpty(..)) reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO () reportError logger nameContext opts span doc = do @@ -47,7 +48,7 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () printMessage logger msg_opts opts message | log_diags_as_json = do - decorated <- decorateDiagnostic logflags messageClass location doc + decorated <- decorateDiagnostic logflags messageClass location sourceSpans doc let rendered :: String rendered = renderWithContext (log_default_user_context logflags) decorated @@ -57,7 +58,7 @@ printMessage logger msg_opts opts message logJsonMsg logger messageClass jsonMessage - | otherwise = logMsg logger messageClass location doc + | otherwise = logMsg (pushLogHook renderWithSourceSpans logger) messageClass location doc where logflags :: LogFlags logflags = logFlags logger @@ -80,9 +81,21 @@ printMessage logger msg_opts opts message diagnostic :: a diagnostic = errMsgDiagnostic message + sourceSpans :: NonEmpty SrcSpan + sourceSpans = location :| diagnosticRelatedLocations diagnostic + severity :: Severity severity = errMsgSeverity message + renderWithSourceSpans :: LogAction -> LogAction + renderWithSourceSpans fallback logflags' msg_class' srcSpan' msg' = + case msg_class' of + MCDiagnostic _ _ _ -> do + decorated <- decorateDiagnostic logflags' msg_class' srcSpan' sourceSpans msg' + fallback logflags' MCInfo noSrcSpan decorated + _ -> + fallback logflags' msg_class' srcSpan' msg' + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -87,6 +87,18 @@ instance Diagnostic GhcMessage where diagnosticCode = constructorCode @GHC + diagnosticRelatedLocations = \case + GhcPsMessage m + -> diagnosticRelatedLocations m + GhcTcRnMessage m + -> diagnosticRelatedLocations m + GhcDsMessage m + -> diagnosticRelatedLocations m + GhcDriverMessage m + -> diagnosticRelatedLocations m + GhcUnknownMessage m + -> diagnosticRelatedLocations m + instance HasDefaultDiagnosticOpts DriverMessageOpts where defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -660,9 +660,10 @@ mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM () dupNamesErr locs names - = addErrAt big_loc (TcRnBindingNameConflict (NE.head names) locs) + = addErrAt (NE.head sorted_locs) + (TcRnBindingNameConflict (NE.head names) sorted_locs) where - big_loc = foldr1 combineSrcSpans locs + sorted_locs = NE.sortBy leftmost_smallest locs badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3455,6 +3455,18 @@ instance Diagnostic TcRnMessage where diagnosticCode = constructorCode @GHC + diagnosticRelatedLocations = \case + TcRnUnknownMessage m + -> diagnosticRelatedLocations m + TcRnMessageWithInfo _ (TcRnMessageDetailed _ msg') + -> diagnosticRelatedLocations msg' + TcRnWithHsDocContext _ msg' + -> diagnosticRelatedLocations msg' + TcRnBindingNameConflict _ locs + -> NE.tail locs + _ -> + [] + pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ [ fsep [ text "Level error:", pprLevelCheckReason reason ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -66,6 +66,7 @@ module GHC.Types.Error , mkLocMessageWarningGroups , formatDiagnostic , getCaretDiagnostic + , getCaretDiagnostics , jsonDiagnostic @@ -108,8 +109,8 @@ import Data.Bifunctor import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE -import Data.List ( intercalate ) -import Data.Maybe ( maybeToList ) +import Data.List ( intercalate, sort ) +import Data.Maybe ( mapMaybe, maybeToList ) import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Text.Printf ( printf ) @@ -277,6 +278,13 @@ class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a -- #18516 tracks our progress toward this goal. diagnosticCode :: a -> Maybe DiagnosticCode + -- | Additional locations related to this diagnostic. + -- + -- When rendering caret diagnostics, these locations are shown alongside the + -- message's primary location. + diagnosticRelatedLocations :: a -> [SrcSpan] + diagnosticRelatedLocations _ = [] + -- | An existential wrapper around an unknown diagnostic. data UnknownDiagnostic opts hint where UnknownDiagnostic :: (Diagnostic a, Typeable a) @@ -295,6 +303,7 @@ instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (Unknown diagnosticReason (UnknownDiagnostic _ _ diag) = diagnosticReason diag diagnosticHints (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag) diagnosticCode (UnknownDiagnostic _ _ diag) = diagnosticCode diag + diagnosticRelatedLocations (UnknownDiagnostic _ _ diag) = diagnosticRelatedLocations diag -- A fallback 'DiagnosticOpts' which can be used when there are no options -- for a particular diagnostic. @@ -785,7 +794,25 @@ getSeverityColour severity = case severity of SevIgnore -> const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic msg_class span = getCaretDiagnostics msg_class (span :| []) + +getCaretDiagnostics :: MessageClass -> NonEmpty SrcSpan -> IO SDoc +getCaretDiagnostics msg_class spans = do + let realSpans = dedupSortedRealSpans spans + maxMarginWidth = + foldl' (\acc s -> max acc (length (show (srcSpanStartLine s)))) 0 realSpans + vcat <$> traverse (getSingleCaretDiagnostic msg_class maxMarginWidth) realSpans + where + dedupSortedRealSpans :: NonEmpty SrcSpan -> [RealSrcSpan] + dedupSortedRealSpans = go Nothing . sort . mapMaybe srcSpanToRealSrcSpan . NE.toList + where + go _ [] = [] + go prev (span:rest) + | Just span == prev = go prev rest + | otherwise = span : go (Just span) rest + +getSingleCaretDiagnostic :: MessageClass -> Int -> RealSrcSpan -> IO SDoc +getSingleCaretDiagnostic msg_class maxMarginWidth span = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -848,9 +875,9 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = | otherwise = srcSpanEndCol span - 1 width = max 1 (end - start) - marginWidth = length rowStr + marginWidth = maxMarginWidth marginSpace = replicate marginWidth ' ' ++ " |" - marginRow = rowStr ++ " |" + marginRow = replicate (marginWidth - length rowStr) ' ' ++ rowStr ++ " |" (srcLinePre, srcLineRest) = splitAt start srcLine (srcLineSpan, srcLinePost) = splitAt width srcLineRest @@ -858,7 +885,6 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -getCaretDiagnostic _ _ = pure empty -- -- Queries -- ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -84,7 +84,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Types.Error ( MessageClass (..), Severity (..) - , mkLocMessageWarningGroups,getCaretDiagnostic ) + , mkLocMessageWarningGroups, getCaretDiagnostics ) -- import GHC.Types.Error () import GHC.Types.SrcLoc @@ -102,6 +102,7 @@ import System.FilePath ( takeDirectory, (</>) ) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Data.List (stripPrefix) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Time import System.IO import Control.Monad @@ -423,7 +424,8 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInfo -> printErrs msg MCFatal -> printErrs msg MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs + MCDiagnostic _sev _rea _code -> + decorateDiagnostic logflags msg_class srcSpan (srcSpan :| []) msg >>= printErrs where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err @@ -463,8 +465,8 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg -- `defaultLogActionWithHandles`) -- -- This story is tracked by #24113. -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> NonEmpty SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan sourceSpans msg = addCaret where -- Pretty print the warning flag, if any (#10752) message :: SDoc @@ -474,7 +476,7 @@ decorateDiagnostic logflags msg_class srcSpan msg = addCaret addCaret = do caretDiagnostic <- if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan + then getCaretDiagnostics msg_class sourceSpans else pure empty return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) ===================================== testsuite/tests/patsyn/should_fail/T14114.stderr ===================================== @@ -1,18 +1,36 @@ - T14114.hs:4:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:4:20 T14114.hs:4:22 • In a pattern synonym declaration + | +4 | pattern Foo1 a <- (a,a) + | ^ + | +4 | pattern Foo1 a <- (a,a) + | ^ T14114.hs:5:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:5:20 T14114.hs:5:22 • In a pattern synonym declaration + | +5 | pattern Foo2 a = (a,a) + | ^ + | +5 | pattern Foo2 a = (a,a) + | ^ T14114.hs:6:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:6:20 T14114.hs:6:22 • In a pattern synonym declaration + | +6 | pattern Foo3 a <- (a,a) where + | ^ + | +6 | pattern Foo3 a <- (a,a) where + | ^ + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -40,7 +40,7 @@ test('T26465', normal, compile_fail, ['']) test('T13349', normal, compile_fail, ['']) test('T13470', normal, compile_fail, ['']) test('T14112', normal, compile_fail, ['']) -test('T14114', normal, compile_fail, ['']) +test('T14114', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14507', normal, compile_fail, ['-dsuppress-uniques']) test('T15289', normal, compile_fail, ['']) test('T15685', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -1,7 +1,7 @@ test('rnfail001', normal, compile_fail, ['']) test('rnfail002', normal, compile_fail, ['']) test('rnfail003', normal, compile_fail, ['']) -test('rnfail004', normal, compile_fail, ['']) +test('rnfail004', normal, compile_fail, ['-fdiagnostics-show-caret']) test('rnfail007', normal, compile_fail, ['']) test('rnfail008', normal, compile_fail, ['']) test('rnfail009', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_fail/rnfail004.stderr ===================================== @@ -1,10 +1,22 @@ - -rnfail004.hs:6:5: [GHC-10498] +rnfail004.hs:6:5: error: [GHC-10498] Conflicting definitions for ‘a’ Bound at: rnfail004.hs:6:5 rnfail004.hs:7:10 + | +6 | a = [] + | ^ + | +7 | (b,c,a) = ([],[],d) + | ^ -rnfail004.hs:7:6: [GHC-10498] +rnfail004.hs:7:6: error: [GHC-10498] Conflicting definitions for ‘b’ Bound at: rnfail004.hs:7:6 rnfail004.hs:8:8 + | +7 | (b,c,a) = ([],[],d) + | ^ + | +8 | [d,b,_] = ([],a,[]) + | ^ + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -31,7 +31,7 @@ test('tcfail034', normal, compile_fail, ['']) test('tcfail035', normal, compile_fail, ['']) test('tcfail036', normal, compile_fail, ['']) test('tcfail037', normal, compile_fail, ['']) -test('tcfail038', normal, compile_fail, ['']) +test('tcfail038', normal, compile_fail, ['-fdiagnostics-show-caret']) test('tcfail040', normal, compile_fail, ['']) test('tcfail041', normal, compile_fail, ['']) test('tcfail042', normal, compile_fail, ['']) ===================================== testsuite/tests/typecheck/should_fail/tcfail038.stderr ===================================== @@ -1,10 +1,22 @@ - -tcfail038.hs:7:11: [GHC-10498] +tcfail038.hs:7:11: error: [GHC-10498] Conflicting definitions for ‘==’ Bound at: tcfail038.hs:7:11-12 tcfail038.hs:9:11-12 + | +7 | a == b = True + | ^^ + | +9 | a == b = False + | ^^ -tcfail038.hs:8:11: [GHC-10498] +tcfail038.hs:8:11: error: [GHC-10498] Conflicting definitions for ‘/=’ Bound at: tcfail038.hs:8:11-12 tcfail038.hs:10:11-12 + | + 8 | a /= b = False + | ^^ + | +10 | a /= b = True + | ^^ + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2180816b5e571ff4da284400f2ff59… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2180816b5e571ff4da284400f2ff59… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/9.10.4-batch1] 8 commits: rts: Dynamically initialize built-in closures
by Andreas Klebinger (＠AndreasK) 25 May '26

25 May '26

Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC Commits: 580bc78d by Ben Gamari at 2026-05-25T16:17:47+02:00 rts: Dynamically initialize built-in closures To resolve #26166 we need to eliminate references to undefined symbols in the runtime system. One such source of these is the runtime's static references to `I#` and `C#` due the `stg_INTLIKE` and `stg_CHARLIKE` arrays. To avoid this we make these dynamic, initializing them during RTS start-up. (cherry picked from commit 39eaaaba5356e3fc9218d8e27375d6de24778cbc) - - - - - d9e27e4d by Rodrigo Mesquita at 2026-05-25T16:17:54+02:00 Move code-gen aux symbols from ghc-internal to rts These symbols were all previously defined in ghc-internal and made the dependency structure awkward, where the rts may refer to some of these symbols and had to work around that circular dependency the way described in #26166. Moreover, the code generator will produce code that uses these symbols! Therefore, they should be available in the rts: PRINCIPLE: If the code generator may produce code which uses this symbol, then it should be defined in the rts rather than, say, ghc-internal. That said, the main motivation is towards fixing #26166. Towards #26166. Pre-requisite of !14892 (cherry picked from commit ba3e5bddb222008591edb6c3d433d93084170571) (cherry picked from commit f687ce93a4ef71aebac5d5eb891e72a090092ec0) - - - - - a703db4f by Ben Gamari at 2026-05-25T16:17:54+02:00 rts: Avoid static symbol references to ghc-internal This resolves #26166, a bug due to new constraints placed by Apple's linker on undefined references. One source of such references in the RTS is the many symbols referenced in ghc-internal. To mitigate #26166, we make these references dynamic, as described in Note [RTS/ghc-internal interface]. Fixes #26166 Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> Co-authored-by: Cheng Shao <terrorjack(a)type.dance> (cherry picked from commit f31de2a9c2405d6645998460e4b501f9279606b3) - - - - - aaa71bb7 by Ben Gamari at 2026-05-25T16:17:54+02:00 compiler: Rename isMathFun -> isLibcFun This set includes more than just math functions. (cherry picked from commit 43fdfddc25c36ef4811941231d5755bad065796d) (cherry picked from commit 99291e88f0498f11317e0f45c4968583c8c6ef0f) - - - - - b73a40a2 by Ben Gamari at 2026-05-25T16:17:54+02:00 compiler: Add libc allocator functions to libc_funs Prototypes for these are now visible from `Prim.h`, resulting in multiple-declaration warnings in the unregisterised job. (cherry picked from commit 4ed5138f7af532731f88380f98103487a9f15c5a) (cherry picked from commit d5d081e38f6abf445ad50b355585d2edddfc8173) - - - - - 6556933a by Ben Gamari at 2026-05-25T16:17:55+02:00 rts: Minimize header dependencies of Prim.h Otherwise we will end up with redundant and incompatible declarations resulting in warnings during the unregisterised build. (cherry picked from commit 9a0a076b80d6fb68d7722d2bb72c17c90ba22cd1) (cherry picked from commit ef442bd152400dc550fba2ba5fd90fb0f5454614) - - - - - 695dc2f5 by sheaf at 2026-05-25T16:17:55+02:00 Use x86_64-unknown-windows-gnu target for LLVM on Windows (cherry picked from commit 21aaa34b703a77f68d3f94e0e9e39ea25499faa2) - - - - - 47464fdf by sheaf at 2026-05-25T16:17:55+02:00 LLVM: use -relocation-model=pic on Windows This is necessary to avoid the segfaults reported in #22487. Fixes #22487 (cherry picked from commit 992a7624817cdab4b566387f2e877f420f7b27d4) - - - - - 62 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToC.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Linker/Static.hs - hadrian/src/Settings/Packages.hs - + libraries/ghc-internal/cbits/RtsIface.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-prim/ghc-prim.cabal - llvm-targets - m4/ghc_llvm_target.m4 - + rts/BuiltinClosures.c - + rts/BuiltinClosures.h - rts/CloneStack.h - rts/Compact.cmm - rts/ContinuationOps.cmm - rts/Exception.cmm - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsAPI.c - rts/RtsStartup.c - rts/RtsSymbols.c - + rts/RtsToHsIface.c - rts/StgMiscClosures.cmm - rts/StgStdThunks.cmm - rts/configure.ac - − rts/external-symbols.list.in - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/Stg.h - rts/include/rts/Constants.h - + rts/include/rts/RtsToHsIface.h - rts/include/rts/Types.h - rts/include/stg/MiscClosures.h - rts/include/stg/Prim.h - rts/posix/Signals.c - libraries/ghc-prim/cbits/atomic.c → rts/prim/atomic.c - libraries/ghc-prim/cbits/bitrev.c → rts/prim/bitrev.c - libraries/ghc-prim/cbits/bswap.c → rts/prim/bswap.c - libraries/ghc-prim/cbits/clz.c → rts/prim/clz.c - libraries/ghc-prim/cbits/ctz.c → rts/prim/ctz.c - + rts/prim/int64x2minmax.c - libraries/ghc-prim/cbits/longlong.c → rts/prim/longlong.c - libraries/ghc-prim/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c - libraries/ghc-prim/cbits/pdep.c → rts/prim/pdep.c - libraries/ghc-prim/cbits/pext.c → rts/prim/pext.c - libraries/ghc-prim/cbits/popcnt.c → rts/prim/popcnt.c - + rts/prim/vectorQuotRem.c - libraries/ghc-prim/cbits/word2float.c → rts/prim/word2float.c - − rts/rts.buildinfo.in - rts/rts.cabal - rts/wasm/JSFFI.c - rts/wasm/scheduler.cmm - rts/win32/libHSghc-internal.def - + testsuite/tests/llvm/should_run/T22487.hs - + testsuite/tests/llvm/should_run/T22487.stdout - testsuite/tests/llvm/should_run/all.T - utils/deriveConstants/Main.hs - utils/llvm-targets/gen-data-layout.sh The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/871e635e359c8840f40d27e9e0d5f0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/871e635e359c8840f40d27e9e0d5f0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] Wibble flag naming
by Simon Peyton Jones (＠simonpj) 25 May '26

25 May '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 70f8849d by Simon Peyton Jones at 2026-05-25T15:24:06+01:00 Wibble flag naming - - - - - 1 changed file: - compiler/GHC/Driver/Session.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2503,8 +2503,8 @@ fFlagsDeps = [ flagSpec "cmm-sink" Opt_CmmSink, flagSpec "cmm-static-pred" Opt_CmmStaticPred, flagSpec "opt-coercion" Opt_OptCoercion, - flagSpec "opt-relco-simpleopt" Opt_OptReflCoSimpleOpt, - flagSpec "opt-relco-simplifier" Opt_OptReflCoSimplifier, + flagSpec "opt-reflco-simpleopt" Opt_OptReflCoSimpleOpt, + flagSpec "opt-reflco-simplifier" Opt_OptReflCoSimplifier, flagSpec "cse" Opt_CSE, flagSpec "stg-cse" Opt_StgCSE, flagSpec "stg-lift-lams" Opt_StgLiftLams, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70f8849dd2587ccd800b4d9472720e1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70f8849dd2587ccd800b4d9472720e1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-hpc-bytecode-modname] ghci: fix module name string lifetime in hs_hpc_module invocation
by Cheng Shao (＠TerrorJack) 25 May '26

25 May '26

Cheng Shao pushed to branch wip/fix-hpc-bytecode-modname at Glasgow Haskell Compiler / GHC Commits: 704164be by Cheng Shao at 2026-05-25T13:59:10+00:00 ghci: fix module name string lifetime in hs_hpc_module invocation This patch makes hpcAddModule pass a properly malloced module name string to hs_hpc_module, instead of using useAsCString which causes use-after-free of module name string. Fixes #27297. Co-authored-by: Codex <codex(a)openai.com> - - - - - 4 changed files: - + libraries/ghc-boot/GHC/Data/ShortByteString.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Run.hs Changes: ===================================== libraries/ghc-boot/GHC/Data/ShortByteString.hs ===================================== @@ -0,0 +1,17 @@ +module GHC.Data.ShortByteString + ( newCStringFromSBS + ) where + +import Prelude + +import qualified Data.ByteString.Short as SBS +import Foreign +import Foreign.C + +newCStringFromSBS :: SBS.ShortByteString -> IO CString +newCStringFromSBS sbs = + SBS.useAsCStringLen sbs $ \(src, len) -> do + dst <- mallocBytes (len + 1) + copyBytes dst src len + pokeByteOff dst len (0 :: Word8) + pure dst ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -51,6 +51,7 @@ Library exposed-modules: GHC.BaseDir + GHC.Data.ShortByteString GHC.Data.ShortText GHC.Data.SizedSeq GHC.Data.SmallArray ===================================== libraries/ghci/GHCi/Coverage.hs ===================================== @@ -9,9 +9,9 @@ import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS import Data.Word import Foreign +import GHC.Data.ShortByteString import GHC.Foreign (CString) import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString) import GHCi.ObjLink (lookupSymbol) @@ -31,17 +31,19 @@ hpcAddModule :: -- ^ Name of the ticks array found in the c-stub. IO () hpcAddModule modlName ticks hash tickboxes = do - SBS.useAsCString modlName $ \modlNameLiteral -> do - -- we need to find the reference to the ticks array. - lookupSymbol tickboxes >>= \ case - Nothing -> do - -- the symbol is not found, this is a bug! - throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes - Just tickBoxRef -> do - -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. - hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) - -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. - hpc_startup + -- we need to find the reference to the ticks array. + lookupSymbol tickboxes >>= \ case + Nothing -> do + -- the symbol is not found, this is a bug! + throwIO $ ErrorCall $ "hpcAddModule: failed to find symbol " <> utf8DecodeShortByteString tickboxes + Just tickBoxRef -> do + -- hs_hpc_module stores the module name pointer in the RTS hash table + -- until exitHpc, so pass a malloced C string. + modlNameLiteral <- newCStringFromSBS modlName + -- Calling 'hs_hpc_module' multiple times is safe, it will add the module only once. + hpc_register_module modlNameLiteral (fromIntegral ticks) (fromIntegral hash) (castPtr tickBoxRef) + -- calling 'hpc_startup' multiple times is safe, it will only be initialised once. + hpc_startup foreign import ccall unsafe "hs_hpc_module" hpc_register_module :: CString -> Word32 -> Word32 -> Ptr Word64 -> IO () ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -37,6 +37,9 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B +#if defined(PROFILING) +import GHC.Data.ShortByteString +#endif import GHC.Exts import qualified GHC.Exts.Heap as Heap import GHC.Stack @@ -447,13 +450,6 @@ mkCostCentres mod ccs = do c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan - newCStringFromSBS sbs = do - let len = BS.length sbs - buf <- mallocBytes $ len + 1 - BS.copyToPtr sbs 0 buf (fromIntegral len) - pokeByteOff buf len (0 :: Word8) - pure buf - foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/704164be09e80185ce78727a4569f8c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/704164be09e80185ce78727a4569f8c… You're receiving this email because of your account on gitlab.haskell.org.

1 0