Implement Text/replace

… as standardized in dhall-lang/dhall-lang#1065

dhall/src/Dhall/Binary.hs

@@ -192,6 +192,7 @@ decodeExpressionInternal decodeEmbed = go
                        | sb == "Natural/even"      -> return NaturalEven
                        | sb == "Natural/fold"      -> return NaturalFold
                        | sb == "Natural/show"      -> return NaturalShow
+                       | sb == "Text/replace"      -> return TextReplace
                     13 | sb == "Integer/clamp"     -> return IntegerClamp
                        | sb == "Natural/build"     -> return NaturalBuild
                     14 | sb == "Integer/negate"    -> return IntegerNegate
@@ -702,6 +703,9 @@ encodeExpressionInternal encodeEmbed = go
         Text ->
             Encoding.encodeUtf8ByteArray "Text"
 
+        TextReplace ->
+            Encoding.encodeUtf8ByteArray "Text/replace"
+
         TextShow ->
             Encoding.encodeUtf8ByteArray "Text/show"
 

dhall/src/Dhall/Diff.hs

@@ -1237,6 +1237,12 @@ diffPrimitiveExpression l@Text r =
     mismatch l r
 diffPrimitiveExpression l r@Text =
     mismatch l r
+diffPrimitiveExpression TextReplace TextReplace =
+    "…"
+diffPrimitiveExpression l@TextReplace r =
+    mismatch l r
+diffPrimitiveExpression l r@TextReplace =
+    mismatch l r
 diffPrimitiveExpression TextShow TextShow =
     "…"
 diffPrimitiveExpression l@TextShow r =

dhall/src/Dhall/Eval.hs

@@ -192,6 +192,7 @@ data Val a
     | VTextLit !(VChunks a)
     | VTextAppend !(Val a) !(Val a)
     | VTextShow !(Val a)
+    | VTextReplace !(Val a) !(Val a) !(Val a)
 
     | VList !(Val a)
     | VListLit !(Maybe (Val a)) !(Seq (Val a))
@@ -362,6 +363,54 @@ vField t0 k = go t0
     singletonVRecordLit v = VRecordLit (Map.singleton k v)
 {-# INLINE vField #-}
 
+vTextReplaceSlow :: Text -> Val a -> VChunks a -> VChunks a
+vTextReplaceSlow needle replacement haystack = go haystack
+  where
+    go (VChunks [] lastText) =
+        if Text.null suffix
+        then VChunks [] lastText
+        else
+            let remainder = Text.drop (Text.length needle) suffix
+
+                rest = go (VChunks [] remainder)
+
+            in  case replacement of
+                    VTextLit replacementChunks ->
+                        VChunks [] prefix <> replacementChunks <> rest
+                    _ ->
+                        VChunks [(prefix, replacement)] "" <> rest
+      where
+        (prefix, suffix) = Text.breakOn needle lastText
+    go (VChunks ((firstText, firstInterpolation) : chunks) lastText) =
+       if Text.null suffix
+       then
+           let rest = go (VChunks chunks lastText)
+
+           in  VChunks [(firstText, firstInterpolation)] "" <> rest
+       else
+           let remainder = Text.drop (Text.length needle) suffix
+
+               rest =
+                   go (VChunks ((remainder, firstInterpolation) : chunks) lastText)
+
+           in  case replacement of
+                   VTextLit replacementChunks ->
+                       VChunks [] prefix <> replacementChunks <> rest
+                   _ ->
+                       VChunks [(prefix, replacement)] "" <> rest
+      where
+        (prefix, suffix) = Text.breakOn needle firstText
+
+vTextReplaceFast :: Text -> Text -> VChunks a -> VChunks a
+vTextReplaceFast needle replacement (VChunks xys z) = VChunks xys' z'
+  where
+    xys' = do
+       (x, y) <- xys
+
+       return (Text.replace needle replacement x, y)
+
+    z' = Text.replace needle replacement z
+
 vProjectByFields :: Eq a => Environment a -> Val a -> Set Text -> Val a
 vProjectByFields env t ks =
     if null ks
@@ -580,6 +629,35 @@ eval !env t0 =
             VPrim $ \case
                 VTextLit (VChunks [] x) -> VTextLit (VChunks [] (textShow x))
                 t                       -> VTextShow t
+        TextReplace ->
+            VPrim $ \needle ->
+            VPrim $ \replacement ->
+            VPrim $ \haystack ->
+                case haystack of
+                    VTextLit haystackChunks ->
+                        case needle of
+                            VTextLit (VChunks [] "") ->
+                                haystack
+                            VTextLit (VChunks [] needleText) ->
+                                case replacement of
+                                    VTextLit (VChunks [] replacementText) ->
+                                        VTextLit
+                                            (vTextReplaceFast
+                                                needleText
+                                                replacementText
+                                                haystackChunks
+                                            )
+                                    _ ->
+                                        VTextLit
+                                            (vTextReplaceSlow
+                                                needleText
+                                                replacement
+                                                haystackChunks
+                                            )
+                            _ ->
+                                VTextReplace needle replacement haystack
+                    _ ->
+                        VTextReplace needle replacement haystack
         List ->
             VPrim VList
         ListLit ma ts ->
@@ -895,6 +973,8 @@ conv !env t0 t0' =
             conv env t t' && conv env u u'
         (VTextShow t, VTextShow t') ->
             conv env t t'
+        (VTextReplace a b c, VTextReplace a' b' c') ->
+            conv env a a' && conv env b b' && conv env c c'
         (VList a, VList a') ->
             conv env a a'
         (VListLit _ xs, VListLit _ xs') ->
@@ -1082,6 +1162,8 @@ quote !env !t0 =
             TextAppend (quote env t) (quote env u)
         VTextShow t ->
             TextShow `qApp` t
+        VTextReplace a b c ->
+            TextReplace `qApp` a `qApp` b `qApp` c
         VList t ->
             List `qApp` t
         VListLit ma ts ->
@@ -1264,6 +1346,8 @@ alphaNormalize = goEnv EmptyNames
                 TextAppend (go t) (go u)
             TextShow ->
                 TextShow
+            TextReplace ->
+                TextReplace
             List ->
                 List
             ListLit ma ts ->

dhall/src/Dhall/Normalize.hs

@@ -43,7 +43,7 @@ import Dhall.Syntax
 
 import qualified Data.Sequence
 import qualified Data.Set
-import qualified Data.Text
+import qualified Data.Text     as Text
 import qualified Dhall.Eval    as Eval
 import qualified Dhall.Map
 import qualified Dhall.Set
@@ -227,7 +227,7 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                     App NaturalOdd (NaturalLit n) -> pure (BoolLit (odd n))
                     App NaturalToInteger (NaturalLit n) -> pure (IntegerLit (toInteger n))
                     App NaturalShow (NaturalLit n) ->
-                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))
+                        pure (TextLit (Chunks [] (Text.pack (show n))))
                     App (App NaturalSubtract (NaturalLit x)) (NaturalLit y)
                         -- Use an `Integer` for the subtraction, due to the
                         -- following issue:
@@ -246,14 +246,14 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                     App IntegerNegate (IntegerLit n) ->
                         pure (IntegerLit (negate n))
                     App IntegerShow (IntegerLit n)
-                        | 0 <= n    -> pure (TextLit (Chunks [] ("+" <> Data.Text.pack (show n))))
-                        | otherwise -> pure (TextLit (Chunks [] (Data.Text.pack (show n))))
+                        | 0 <= n    -> pure (TextLit (Chunks [] ("+" <> Text.pack (show n))))
+                        | otherwise -> pure (TextLit (Chunks [] (Text.pack (show n))))
                     -- `(read . show)` is used instead of `fromInteger` because `read` uses
                     -- the correct rounding rule.
                     -- See https://gitlab.haskell.org/ghc/ghc/issues/17231.
                     App IntegerToDouble (IntegerLit n) -> pure (DoubleLit ((DhallDouble . read . show) n))
                     App DoubleShow (DoubleLit (DhallDouble n)) ->
-                        pure (TextLit (Chunks [] (Data.Text.pack (show n))))
+                        pure (TextLit (Chunks [] (Text.pack (show n))))
                     App (App ListBuild _A₀) g -> loop (App (App (App g list) cons) nil)
                       where
                         _A₁ = Syntax.shift 1 "a" _A₀
@@ -318,6 +318,64 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
                         loop (TextLit (Chunks [] newText))
                       where
                         newText = Eval.textShow oldText
+                    App
+                        (App (App TextReplace (TextLit (Chunks [] ""))) _)
+                        haystack ->
+                            return haystack
+                    App (App
+                            (App TextReplace (TextLit (Chunks [] needleText)))
+                            (TextLit (Chunks [] replacementText))
+                        )
+                        (TextLit (Chunks xys z)) -> do
+                            let xys' = do
+                                    (x, y) <- xys
+
+                                    let x' = Text.replace needleText replacementText x
+                                    return (x', y)
+
+                            let z' = Text.replace needleText replacementText z
+
+                            return (TextLit (Chunks xys' z'))
+                    App (App
+                            (App TextReplace (TextLit (Chunks [] needleText)))
+                            replacement
+                        )
+                        (TextLit (Chunks [] lastText)) -> do
+                            let (prefix, suffix) =
+                                    Text.breakOn needleText lastText
+
+                            if Text.null suffix
+                                then return (TextLit (Chunks [] lastText))
+                                else do
+                                    let remainder =
+                                            Text.drop
+                                                (Text.length needleText)
+                                                suffix
+
+                                    loop (TextAppend (TextLit (Chunks [(prefix, replacement)] "")) (App (App (App TextReplace (TextLit (Chunks [] needleText))) replacement) (TextLit (Chunks [] remainder))))
+                    App (App
+                            (App TextReplace (TextLit (Chunks [] needleText)))
+                            replacement
+                        )
+                        (TextLit
+                            (Chunks
+                                ((firstText, firstInterpolation) : chunks)
+                                lastText
+                            )
+                        ) -> do
+                            let (prefix, suffix) =
+                                    Text.breakOn needleText firstText
+
+                            if Text.null suffix
+                                then do
+                                    loop (TextAppend (TextLit (Chunks [(firstText, firstInterpolation)] "")) (App (App (App TextReplace (TextLit (Chunks [] needleText))) replacement) (TextLit (Chunks chunks lastText))))
+                                else do
+                                    let remainder =
+                                            Text.drop
+                                                (Text.length needleText)
+                                                suffix
+
+                                    loop (TextAppend (TextLit (Chunks [(prefix, replacement)] "")) (App (App (App TextReplace (TextLit (Chunks [] needleText))) replacement) (TextLit (Chunks ((remainder, firstInterpolation) : chunks) lastText))))
                     _ -> do
                         res2 <- ctx (App f' a')
                         case res2 of
@@ -420,6 +478,7 @@ normalizeWithM ctx e0 = loop (Syntax.denote e0)
             TextLit c -> pure [Chunks [] x, c]
             _         -> pure [Chunks [(x, y')] mempty]
     TextAppend x y -> loop (TextLit (Chunks [("", x), ("", y)] ""))
+    TextReplace -> pure TextReplace
     TextShow -> pure TextShow
     List -> pure List
     ListLit t es
@@ -703,6 +762,10 @@ isNormalized e0 = loop (Syntax.denote e0)
           App (App ListReverse _) (ListLit _ _) -> False
           App TextShow (TextLit (Chunks [] _)) ->
               False
+          App (App (App TextReplace (TextLit (Chunks [] ""))) _) _ ->
+              False
+          App (App (App TextReplace (TextLit (Chunks [] _))) _) (TextLit _) ->
+              False
           _ -> True
       Let _ _ -> False
       Annot _ _ -> False
@@ -775,6 +838,7 @@ isNormalized e0 = loop (Syntax.denote e0)
               TextLit _ -> False
               _         -> True
       TextAppend _ _ -> False
+      TextReplace -> True
       TextShow -> True
       List -> True
       ListLit t es -> all loop t && all loop es

dhall/src/Dhall/Parser/Expression.hs

@@ -580,7 +580,8 @@ parsers embedded = Parsers {..}
                     'S' ->    Const Sort       <$ _Sort
                     'T' ->
                         choice
-                            [ TextShow         <$ _TextShow
+                            [ TextReplace      <$ _TextReplace
+                            , TextShow         <$ _TextShow
                             , Text             <$ _Text
                             , BoolLit True     <$ _True
                             , Const Type       <$ _Type

dhall/src/Dhall/Parser/Token.hs

@@ -65,6 +65,7 @@ module Dhall.Parser.Token (
     _Integer,
     _Double,
     _Text,
+    _TextReplace,
     _TextShow,
     _List,
     _True,
@@ -1053,6 +1054,13 @@ _Double = builtin "Double"
 _Text :: Parser ()
 _Text = builtin "Text"
 
+{-| Parse the @Text/replace@ built-in
+
+    This corresponds to the @Text-replace@ rule from the official grammar
+-}
+_TextReplace :: Parser ()
+_TextReplace = builtin "Text/replace"
+
 {-| Parse the @Text/show@ built-in
 
     This corresponds to the @Text-show@ rule from the official grammar

dhall/src/Dhall/Pretty/Internal.hs

@@ -1258,6 +1258,8 @@ prettyPrinters characterSet =
         builtin "Double/show"
     prettyPrimitiveExpression Text =
         builtin "Text"
+    prettyPrimitiveExpression TextReplace =
+        builtin "Text/replace"
     prettyPrimitiveExpression TextShow =
         builtin "Text/show"
     prettyPrimitiveExpression List =

dhall/src/Dhall/Syntax.hs

@@ -506,9 +506,9 @@ data Expr s a
     | Integer
     -- | > IntegerLit n                             ~  ±n
     | IntegerLit Integer
-    -- | > IntegerClamp                               ~  Integer/clamp
+    -- | > IntegerClamp                             ~  Integer/clamp
     | IntegerClamp
-    -- | > IntegerNegate                              ~  Integer/negate
+    -- | > IntegerNegate                            ~  Integer/negate
     | IntegerNegate
     -- | > IntegerShow                              ~  Integer/show
     | IntegerShow
@@ -526,6 +526,8 @@ data Expr s a
     | TextLit (Chunks s a)
     -- | > TextAppend x y                           ~  x ++ y
     | TextAppend (Expr s a) (Expr s a)
+    -- | > TextReplace                              ~ Text/replace
+    | TextReplace
     -- | > TextShow                                 ~  Text/show
     | TextShow
     -- | > List                                     ~  List
@@ -809,6 +811,7 @@ unsafeSubExpressions _ Text = pure Text
 unsafeSubExpressions f (TextLit chunks) =
     TextLit <$> chunkExprs f chunks
 unsafeSubExpressions f (TextAppend a b) = TextAppend <$> f a <*> f b
+unsafeSubExpressions _ TextReplace = pure TextReplace
 unsafeSubExpressions _ TextShow = pure TextShow
 unsafeSubExpressions _ List = pure List
 unsafeSubExpressions f (ListLit a b) = ListLit <$> traverse f a <*> traverse f b
@@ -1202,6 +1205,7 @@ reservedIdentifiers = reservedKeywords <>
         , "List/last"
         , "List/indexed"
         , "List/reverse"
+        , "Text/replace"
         , "Text/show"
         , "Bool"
         , "True"

dhall/src/Dhall/TypeCheck.hs

@@ -580,6 +580,16 @@ infer typer = loop
 
             return VText
 
+        TextReplace ->
+            return
+                (   VHPi "needle" VText  (\_needle ->
+                        VHPi "replacement" VText (\_replacement ->
+                            VHPi "haystack" VText (\_haystack ->
+                                VText
+                            )
+                        )
+                    )
+                )
         TextShow ->
             return (VText ~> VText)
 

dhall/tests/Dhall/Test/QuickCheck.hs

@@ -374,6 +374,7 @@ instance (Arbitrary s, Arbitrary a) => Arbitrary (Expr s a) where
             % (1 :: W "Text")
             % (1 :: W "TextLit")
             % (1 :: W "TextAppend")
+            % (1 :: W "TextReplace")
             % (1 :: W "TextShow")
             % (1 :: W "List")
             % (1 :: W "ListLit")