Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Builtin/Names.hs
    ... ... @@ -282,7 +282,11 @@ basicKnownKeyNames
    282 282 
             fromStringName,
    283 283
    284 284 
             -- Interpolated strings
    285 
    -        interpolateStringName,
    285 
    +        interpolateRawName,
    286 
    +        interpolateValueName,
    287 
    +        interpolateAppendName,
    288 
    +        interpolateEmptyName,
    289 
    +        interpolateFinalizeName,
    286 290
    287 291 
             -- Enum stuff
    288 292 
             enumFromName, enumFromThenName,
    ... ... @@ -1090,8 +1094,17 @@ minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpK
    1090 1094 
     negateName        = varQual gHC_INTERNAL_NUM (fsLit "negate")      negateClassOpKey
    1091 1095
    1092 1096 
     -- Module GHC.Internal.Data.String.Interpolate
    1093 
    -interpolateStringName :: Name
    1094 
    -interpolateStringName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateString") interpolateStringKey
    1097 
    +interpolateRawName
    1098 
    +  , interpolateValueName
    1099 
    +  , interpolateAppendName
    1100 
    +  , interpolateEmptyName
    1101 
    +  , interpolateFinalizeName
    1102 
    +  :: Name
    1103 
    +interpolateRawName      = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateRaw"     ) interpolateRawKey
    1104 
    +interpolateValueName    = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateValue"   ) interpolateValueKey
    1105 
    +interpolateAppendName   = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateAppend"  ) interpolateAppendKey
    1106 
    +interpolateEmptyName    = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateEmpty"   ) interpolateEmptyKey
    1107 
    +interpolateFinalizeName = varQual gHC_INTERNAL_DATA_STRING_INTERPOLATE (fsLit "interpolateFinalize") interpolateFinalizeKey
    1095 1108
    1096 1109 
     ---------------------------------
    1097 1110 
     -- ghc-bignum
    ... ... @@ -2392,8 +2405,17 @@ proxyHashKey :: Unique
    2392 2405 
     proxyHashKey = mkPreludeMiscIdUnique 502
    2393 2406
    2394 2407 
     -- String interpolation
    2395 
    -interpolateStringKey :: Unique
    2396 
    -interpolateStringKey = mkPreludeMiscIdUnique 576
    2408 
    +interpolateRawKey
    2409 
    +  , interpolateValueKey
    2410 
    +  , interpolateAppendKey
    2411 
    +  , interpolateEmptyKey
    2412 
    +  , interpolateFinalizeKey
    2413 
    +  :: Unique
    2414 
    +interpolateRawKey = mkPreludeMiscIdUnique 576
    2415 
    +interpolateValueKey = mkPreludeMiscIdUnique 577
    2416 
    +interpolateAppendKey = mkPreludeMiscIdUnique 578
    2417 
    +interpolateEmptyKey = mkPreludeMiscIdUnique 579
    2418 
    +interpolateFinalizeKey = mkPreludeMiscIdUnique 580
    2397 2419
    2398 2420 
     ---------------- Template Haskell -------------------
    2399 2421 
     --      GHC.Builtin.Names.TH: USES IdUniques 200-499

  • compiler/GHC/Rename/String.hs
    ... ... @@ -8,14 +8,12 @@ import GHC.Prelude
    8 8
    9 9 
     import Data.Maybe (isNothing)
    10 10 
     import qualified GHC.Builtin.Names as Builtin
    11 
    -import GHC.Builtin.Types (stringTyConName)
    12 11 
     import GHC.Data.StringMeta (StringMeta (..))
    13 12 
     import GHC.Hs
    14 13 
     import qualified GHC.LanguageExtensions as LangExt
    15 
    -import GHC.Rename.Env (lookupNameWithQualifier)
    16 
    -import GHC.Rename.Pat (rnOverLit)
    14 
    +import GHC.Rename.Env (lookupNameWithQualifier, lookupSyntaxName)
    17 15 
     import GHC.Tc.Utils.Monad
    18 
    -import GHC.Types.Name (mkVarOcc)
    16 
    +import GHC.Types.Name (Name)
    19 17 
     import GHC.Types.Name.Set (FreeNames, emptyFNs, plusFNs)
    20 18 
     import GHC.Types.SrcLoc (unLoc)
    21 19
    ... ... @@ -59,58 +57,46 @@ rewriteInterString ::
    59 57 
       [HsInterStringPart GhcRn] ->
    60 58 
       RnM (HsExpr GhcRn, FreeNames)
    61 59 
     rewriteInterString meta parts = do
    62 
    -  overloaded <- xoptM LangExt.OverloadedStrings
    63 
    -  convertName <- newName (mkVarOcc "convert")
    64 
    -  rawName <- newName (mkVarOcc "raw")
    65 
    -  mappendName <- newName (mkVarOcc "mappend")
    66 
    -  memptyName <- newName (mkVarOcc "mempty")
    67 
    -
    68 
    -  (interpolateStringName, fvs1) <-
    69 
    -    case strMetaQualified meta of
    70 
    -      Just modName -> lookupNameWithQualifier Builtin.interpolateStringName modName
    71 
    -      Nothing -> pure (Builtin.interpolateStringName, emptyFNs)
    72 
    -  (parts', fvs2) <- unzip <$> mapM (rewritePart overloaded convertName rawName) parts
    60 
    +  mkOverloaded <- get_mkOverloaded
    61 
    +
    62 
    +  let lookupName' = lookupName (strMetaQualified meta)
    63 
    +  (rawName, fns1) <- lookupName' Builtin.interpolateRawName
    64 
    +  (convertName, fns2) <- lookupName' Builtin.interpolateValueName
    65 
    +  (appendName, fns3) <- lookupName' Builtin.interpolateAppendName
    66 
    +  (emptyName, fns4) <- lookupName' Builtin.interpolateEmptyName
    67 
    +  (finalizeName, fns5) <- lookupName' Builtin.interpolateFinalizeName
    68 
    +
    73 69 
       let expr =
    74 
    -        (if not overloaded && isNothing (strMetaQualified meta) then addSig else id)
    75 
    -          . nlHsApp (nlHsVar interpolateStringName)
    76 
    -          . mkLam
    77 
    -              [ nlVarPat convertName
    78 
    -              , nlVarPat rawName
    79 
    -              , nlVarPat mappendName
    80 
    -              , nlVarPat memptyName
    81 
    -              ]
    82 
    -          $ foldr (\p acc -> nlHsApps mappendName [p, acc]) (nlHsVar memptyName) parts'
    83 
    -
    84 
    -  pure (unLoc expr, plusFNs $ [fvs1] ++ fvs2)
    70 
    +        unLoc
    71 
    +          . mkOverloaded
    72 
    +          . nlHsApp (nlHsVar finalizeName)
    73 
    +          . foldr (\p acc -> nlHsApps appendName [p, acc]) (nlHsVar emptyName)
    74 
    +          $ map (rewritePart convertName rawName) parts
    75 
    +
    76 
    +  pure (expr, plusFNs [fns1, fns2, fns3, fns4, fns5])
    85 77 
       where
    86 
    -    mkLam pats body = mkHsLam (noLocA pats) body
    87 
    -
    88 
    -    rewritePart overloaded convertName rawName = \case
    89 
    -      HsInterStringRaw st s -> do
    90 
    -        (lit, fvs) <- mkStringLit overloaded st s
    91 
    -        pure (nlHsApps rawName [lit], fvs)
    92 
    -      HsInterStringExpr _ e ->
    93 
    -        pure (nlHsApps convertName [e], emptyFNs)
    94 
    -
    95 
    -    -- Add ":: String" to the given expression
    96 
    -    addSig e =
    97 
    -      noLocA . ExprWithTySig noExtField e $
    98 
    -        HsWC
    99 
    -          { hswc_ext = []
    100 
    -          , hswc_body =
    101 
    -              noLocA
    102 
    -                HsSig
    103 
    -                  { sig_ext   = noExtField
    104 
    -                  , sig_bndrs = HsOuterImplicit []
    105 
    -                  , sig_body  = nlHsTyVar NotPromoted stringTyConName
    106 
    -                  }
    107 
    -          }
    108 
    -
    109 
    -    mkStringLit overloaded st s = do
    110 
    -      if overloaded
    111 
    -        then do
    112 
    -          -- FIXME(bchinn): allow -XRebindableSyntax -- lookupSyntaxName
    113 
    -          (expr, fvs) <- rnOverLit noExtField $ OverLit noExtField (HsIsString st s)
    114 
    -          pure (noLocA expr, fvs)
    115 
    -        else
    116 
    -          pure (nlHsLit $ HsString st s, emptyFNs)
    78 
    +    rewritePart convertName rawName = \case
    79 
    +      HsInterStringRaw st s -> nlHsApps rawName [nlHsLit $ HsString st s]
    80 
    +      HsInterStringExpr _ e -> nlHsApps convertName [e]
    81 
    +
    82 
    +    -- Handle -XOverloadedStrings
    83 
    +    get_mkOverloaded = do
    84 
    +      overloaded <- xoptM LangExt.OverloadedStrings
    85 
    +      pure $
    86 
    +        if overloaded && isNothing (strMetaQualified meta)
    87 
    +          then nlHsApp (nlHsVar Builtin.fromStringName)
    88 
    +          else id
    89 
    +
    90 
    +-- | Look up the given name in the following places:
    91 
    +--     1. If the given module is provided, in the module
    92 
    +--     2. If -XRebindableSyntax, any name in scope
    93 
    +--     3. Otherwise, return the built-in name.
    94 
    +lookupName :: Maybe ModuleName -> Name -> RnM (Name, FreeNames)
    95 
    +lookupName mQualMod name
    96 
    +  | Just mod <- mQualMod =
    97 
    +      lookupNameWithQualifier name mod
    98 
    +  | otherwise = do
    99 
    +      isRebindable <- xoptM LangExt.RebindableSyntax
    100 
    +      if isRebindable
    101 
    +        then lookupSyntaxName name
    102 
    +        else pure (name, emptyFNs)

  • libraries/ghc-experimental/ghc-experimental.cabal.in
    ... ... @@ -34,6 +34,7 @@ library
    34 34 
         import:           warnings
    35 35 
         exposed-modules:
    36 36 
           Data.String.Interpolate.Experimental
    37 
    +      Data.String.Interpolate.Basic.Experimental
    37 38 
           Data.Sum.Experimental
    38 39 
           Data.Tuple.Experimental
    39 40 
           GHC.PrimOps

  • libraries/ghc-experimental/src/Data/String/Interpolate/Basic/Experimental.hs
    1 
    +module Data.String.Interpolate.Basic.Experimental where
    2 
    +
    3 
    +import Data.String (IsString (..))
    4 
    +
    5 
    +interpolateRaw :: IsString s => String -> s
    6 
    +interpolateRaw = fromString
    7 
    +
    8 
    +interpolateValue :: s -> s
    9 
    +interpolateValue = id
    10 
    +
    11 
    +interpolateAppend :: Monoid s => s -> s -> s
    12 
    +interpolateAppend = mappend
    13 
    +
    14 
    +interpolateEmpty :: Monoid s => s
    15 
    +interpolateEmpty = mempty
    16 
    +
    17 
    +interpolateFinalize :: s -> s
    18 
    +interpolateFinalize = id

  • libraries/ghc-experimental/src/Data/String/Interpolate/Experimental.hs
    ... ... @@ -14,8 +14,13 @@ See the proposal for motivation and explanations:
    14 14 
     https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0570-string-interpolation.rst
    15 15 
     -}
    16 16 
     module Data.String.Interpolate.Experimental (
    17 
    -  SimpleStringInterpolator,
    18 
    -  interpolateString,
    17 
    +  interpolateRaw,
    18 
    +  interpolateValue,
    19 
    +  interpolateAppend,
    20 
    +  interpolateEmpty,
    21 
    +  interpolateFinalize,
    22 
    +
    23 
    +  -- * Interpolate class
    19 24 
       Interpolate (..),
    20 25 
     ) where
    21 26

  • libraries/ghc-internal/src/GHC/Internal/Data/String/Interpolate.hs
    ... ... @@ -12,57 +12,73 @@
    12 12 
     --
    13 13 
     -----------------------------------------------------------------------------
    14 14 
     {-# LANGUAGE CPP #-}
    15 
    +{-# LANGUAGE DefaultSignatures #-}
    16 
    +{-# LANGUAGE DerivingStrategies #-}
    17 
    +{-# LANGUAGE FlexibleContexts #-}
    15 18 
     {-# LANGUAGE FlexibleInstances #-}
    19 
    +{-# LANGUAGE GeneralizedNewtypeDeriving #-}
    16 20 
     {-# LANGUAGE RankNTypes #-}
    21 
    +{-# LANGUAGE TypeFamilies #-}
    22 
    +{-# LANGUAGE UndecidableSuperClasses #-}
    17 23
    18 24 
     module GHC.Internal.Data.String.Interpolate (
    19 
    -  SimpleStringInterpolator,
    20 
    -  interpolateString,
    25 
    +  interpolateRaw,
    26 
    +  interpolateValue,
    27 
    +  interpolateAppend,
    28 
    +  interpolateEmpty,
    29 
    +  interpolateFinalize,
    30 
    +
    31 
    +  -- * StringBuilder
    32 
    +  StringBuilder (..),
    33 
    +  buildString,
    34 
    +
    35 
    +  -- * Interpolate class
    21 36 
       Interpolate (..),
    22 37 
     ) where
    23 38
    24 39 
     import GHC.Internal.Base
    25 
    -import GHC.Internal.Data.Maybe (Maybe (..))
    40 
    +import GHC.Internal.Data.Monoid (Endo (..))
    26 41 
     import GHC.Internal.Data.String (IsString, fromString)
    27 
    -import GHC.Internal.Show (ShowS, showChar, showString, shows)
    42 
    +import GHC.Internal.Show (show)
    28 43 
     import GHC.Internal.Types
    29 44
    30 
    -type SimpleStringInterpolator s =
    31 
    -  ( forall ss.
    32 
    -    (forall a. Interpolate a => a -> s)
    33 
    -    -> (s -> s)
    34 
    -    -> (s -> ss -> ss)
    35 
    -    -> ss
    36 
    -    -> ss
    37 
    -  )
    38 
    -  -> s
    45 
    +interpolateRaw :: String -> StringBuilder
    46 
    +interpolateRaw = fromString
    39 47
    40 
    -interpolateString :: (IsString s, Monoid s) => SimpleStringInterpolator s
    41 
    -interpolateString f = mconcat $ f (fromString . interpolate) id (:) []
    42 
    -{-# INLINE interpolateString #-}
    48 
    +interpolateValue :: Interpolate a => a -> StringBuilder
    49 
    +interpolateValue = interpolate
    43 50
    44 
    -class Interpolate a where
    45 
    -  {-# MINIMAL interpolate | interpolateS #-}
    51 
    +interpolateAppend :: StringBuilder -> StringBuilder -> StringBuilder
    52 
    +interpolateAppend = mappend
    46 53
    47 
    -  interpolate :: a -> String
    48 
    -  interpolate x = interpolateS x ""
    54 
    +interpolateEmpty :: StringBuilder
    55 
    +interpolateEmpty = mempty
    49 56
    50 
    -  interpolateS :: a -> ShowS
    51 
    -  interpolateS x s = interpolate x <> s
    57 
    +interpolateFinalize :: StringBuilder -> String
    58 
    +interpolateFinalize = buildString
    52 59
    53 
    -instance Interpolate String where
    54 
    -  interpolateS = showString
    55 
    -instance Interpolate Char where
    56 
    -  interpolateS = showChar
    60 
    +{----- StringBuilder -----}
    61 
    +
    62 
    +newtype StringBuilder = StringBuilder (Endo String)
    63 
    +  deriving newtype (Semigroup, Monoid)
    64 
    +instance IsString StringBuilder where
    65 
    +  fromString s = StringBuilder (Endo (s <>))
    57 66
    58 
    -#define INTERPOLATE_WITH_SHOW(x) \
    59 
    -  instance Interpolate x where \
    60 
    -    interpolateS = shows
    61 
    -INTERPOLATE_WITH_SHOW(Int)
    62 
    -INTERPOLATE_WITH_SHOW(Double)
    63 
    -INTERPOLATE_WITH_SHOW(Bool)
    64 
    --- FIXME(bchinn): More instances
    67 
    +buildString :: StringBuilder -> String
    68 
    +buildString (StringBuilder (Endo f)) = f ""
    65 69
    66 
    -instance Interpolate a => Interpolate (Maybe a) where
    67 
    -  interpolateS Nothing = showString "Nothing"
    68 
    -  interpolateS (Just a) = showString "Just (" . interpolateS a . showChar ')'
    70 
    +{---- Interpolate ----}
    71 
    +
    72 
    +class Interpolate a where
    73 
    +  interpolate :: (IsString s, Monoid s) => a -> s
    74 
    +
    75 
    +instance Interpolate String where
    76 
    +  interpolate = fromString
    77 
    +instance Interpolate Char where
    78 
    +  interpolate c = fromString [c]
    79 
    +instance Interpolate Int where
    80 
    +  interpolate = interpolate . show
    81 
    +instance Interpolate Double where
    82 
    +  interpolate = interpolate . show
    83 
    +instance Interpolate Bool where
    84 
    +  interpolate = interpolate . show

  • testsuite/tests/parser/should_run/StringInterpolationOverloaded.hs
    ... ... @@ -2,10 +2,15 @@
    2 2 
     {-# LANGUAGE OverloadedStrings #-}
    3 3 
     {-# LANGUAGE RecordWildCards #-}
    4 4 
     {-# LANGUAGE StringInterpolation #-}
    5 
    +{-# LANGUAGE TypeFamilies #-}
    5 6
    6 7 
     import Data.String.Interpolate.Experimental
    7 8 
     import Data.Text (Text)
    8 9 
     import Data.Text qualified as Text
    10 
    +import Data.Text.Lazy.Builder qualified as LazyText
    11 
    +import Data.Text.Lazy.Builder.Int qualified as LazyText
    12 
    +import Data.Text.Lazy.Builder.RealFloat qualified as LazyText
    13 
    +import Data.Text.Lazy qualified as LazyText
    9 14
    10 15 
     main :: IO ()
    11 16 
     main = mapM_ runTest allTests
    ... ... @@ -30,14 +35,14 @@ allTests =
    30 35 
       [ TestCase -- Text
    31 36 
           { label =
    32 37 
               """
    33 
    -          let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text
    38 
    +          let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text
    34 39 
               """
    35 40 
           , expression =
    36 
    -          let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text
    41 
    +          let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text
    37 42 
           }
    38 43 
       -- FIXME(bchinn): overloaded interpolated multiline string
    39 44 
       ]
    40 45
    41 46 
     -- Remove when text provides this instance
    42 47 
     instance Interpolate Text where
    43 
    -  interpolateS = interpolateS . Text.unpack
    48 
    +  interpolate = interpolate . Text.unpack

  • testsuite/tests/parser/should_run/StringInterpolationOverloaded.stdout
    1 1 
     ****************************************
    2 2 
     Input:
    3 
    -    let s = "world"; x = True in s <> s" hello ${s} ${x}" :: Text
    3 
    +    let s = "world" :: Text; x = True in s <> s" hello ${s} ${x}" :: Text
    4 4 
     ====>
    5 5 
         "world hello world True"

  • testsuite/tests/qualified-strings/should_run/Example/SQL.hs
    1 1 
     module Example.SQL (
    2 2 
       SqlQuery (..),
    3 3 
       SqlValue (..),
    4 
    -  interpolateString,
    4 
    +
    5 
    +  -- * String interpolation
    6 
    +  interpolateRaw,
    7 
    +  interpolateValue,
    8 
    +  interpolateAppend,
    9 
    +  interpolateEmpty,
    10 
    +  interpolateFinalize,
    5 11 
     ) where
    6 12
    7 13 
     import Data.String (IsString (..))
    ... ... @@ -41,12 +47,17 @@ instance ToSqlQuery String where
    41 47 
     instance ToSqlQuery Int where
    42 48 
       toSqlQuery x = SqlQuery{sqlText = "?", sqlValues = [SqlInt x]}
    43 49
    44 
    -interpolateString ::
    45 
    -  ( (forall a. ToSqlQuery a => a -> SqlQuery) ->
    46 
    -    (String -> SqlQuery) ->
    47 
    -    (SqlQuery -> SqlQuery -> SqlQuery) ->
    48 
    -    SqlQuery ->
    49 
    -    SqlQuery
    50 
    -  ) ->
    51 
    -  SqlQuery
    52 
    -interpolateString f = f toSqlQuery fromString (<>) mempty
    50 
    +interpolateRaw :: String -> SqlQuery
    51 
    +interpolateRaw = fromString
    52 
    +
    53 
    +interpolateValue :: ToSqlQuery a => a -> SqlQuery
    54 
    +interpolateValue = toSqlQuery
    55 
    +
    56 
    +interpolateAppend :: SqlQuery -> SqlQuery -> SqlQuery
    57 
    +interpolateAppend = mappend
    58 
    +
    59 
    +interpolateEmpty :: SqlQuery
    60 
    +interpolateEmpty = mempty
    61 
    +
    62 
    +interpolateFinalize :: SqlQuery -> SqlQuery
    63 
    +interpolateFinalize = id

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help