Merge branch 'fix-json-escaping-2'

Author: istathar

core-data/core-data.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           core-data
-version:        0.3.2.1
+version:        0.3.2.2
 synopsis:       Convenience wrappers around common data structures and encodings
 description:    Wrappers around common data structures and encodings.
                 .
@@ -46,7 +46,7 @@ library
     , base >=4.11 && <5
     , bytestring
     , containers
-    , core-text >=0.3.4
+    , core-text >=0.3.7
     , hashable >=1.2
     , prettyprinter >=1.6.2
     , scientific

core-data/lib/Core/Encoding/Json.hs

@@ -67,6 +67,13 @@ module Core.Encoding.Json (
     prettyValue,
 ) where
 
+#if MIN_VERSION_aeson(2,0,1)
+import qualified Data.Aeson.Key as Aeson
+import qualified Data.Aeson.KeyMap as Aeson
+#else
+import qualified Data.HashMap.Strict as HashMap
+#endif
+
 import Core.Data.Structures (Key, Map, fromMap, intoMap)
 import Core.Text.Bytes (Bytes, fromBytes, intoBytes)
 import Core.Text.Colour (
@@ -86,21 +93,15 @@ import Core.Text.Rope (
     fromRope,
     intoRope,
     singletonRope,
+    unconsRope,
  )
 import Core.Text.Utilities (
     Render (Token, colourize, highlight),
-    breakPieces,
+    breakRope,
  )
-import qualified Data.Aeson as Aeson
-
-#if MIN_VERSION_aeson(2,0,1)
-import qualified Data.Aeson.Key as Aeson
-import qualified Data.Aeson.KeyMap as Aeson
-#else
-import qualified Data.HashMap.Strict as HashMap
-#endif
-
 import Data.Aeson (FromJSON, Value (String))
+import qualified Data.Aeson as Aeson
+import Data.Char (intToDigit)
 import Data.Coerce
 import Data.Hashable (Hashable)
 import qualified Data.List as List
@@ -178,26 +179,34 @@ encodeToRope value = case value of
     closebracket = singletonRope ']'
 
 {- |
-Escape any quotes or backslashes in a JsonString.
+Escape any quotes, backslashes, or other possible rubbish in a 'JsonString'.
 -}
 escapeString :: Rope -> Rope
 escapeString text =
-    let text1 = escapeBackslashes text
-        text2 = escapeQuotes text1
-      in text2
+    let (before, after) = breakRope needsEscaping text
+     in case unconsRope after of
+            Nothing ->
+                text
+            Just (c, after') ->
+                before <> escapeCharacter c <> escapeString after'
+  where
+    needsEscaping c =
+        c == '\"' || c == '\\' || c < '\x20'
 {-# INLINEABLE escapeString #-}
 
-escapeBackslashes :: Rope -> Rope
-escapeBackslashes text =
-     let pieces = breakPieces (== '\\') text
-     in mconcat (List.intersperse "\\\\" pieces)
-{-# INLINEABLE escapeBackslashes #-}
-
-escapeQuotes :: Rope -> Rope
-escapeQuotes text =
-    let pieces = breakPieces (== '"') text
-     in mconcat (List.intersperse "\\\"" pieces)
-{-# INLINEABLE escapeQuotes #-}
+escapeCharacter :: Char -> Rope
+escapeCharacter c =
+    case c of
+        '\"' -> "\\\""
+        '\\' -> "\\\\"
+        '\n' -> "\\n"
+        '\r' -> "\\r"
+        '\t' -> "\\t"
+        _ ->
+            if c < '\x10'
+                then "\\u000" <> singletonRope (intToDigit (fromEnum c))
+                else "\\u001" <> singletonRope (intToDigit ((fromEnum c) - 16))
+{-# INLINEABLE escapeCharacter #-}
 
 {- |
 Given an array of bytes, attempt to decode it as a JSON value.

core-data/package.yaml

@@ -1,5 +1,5 @@
 name: core-data
-version: 0.3.2.1
+version: 0.3.2.2
 synopsis: Convenience wrappers around common data structures and encodings
 description: |
   Wrappers around common data structures and encodings.
@@ -33,7 +33,7 @@ dependencies:
  - text
  - unordered-containers
  - vector
- - core-text >= 0.3.4
+ - core-text >= 0.3.7
 
 library:
   source-dirs: lib

core-program/lib/Core/Program/Metadata.hs

@@ -150,12 +150,12 @@ readCabalFile = runIO $ do
 
 parseCabalFile :: Bytes -> Map Rope Rope
 parseCabalFile contents =
-    let breakup = intoMap . fmap (breakRope (== ':')) . breakLines . fromBytes
+    let breakup = intoMap . fmap (breakRope' (== ':')) . breakLines . fromBytes
      in breakup contents
 
 -- this should probably be a function in Core.Text.Rope
-breakRope :: (Char -> Bool) -> Rope -> (Rope, Rope)
-breakRope predicate text =
+breakRope' :: (Char -> Bool) -> Rope -> (Rope, Rope)
+breakRope' predicate text =
     let pieces = take 2 (breakPieces predicate text)
      in case pieces of
             [] -> ("", "")

core-text/core-text.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           core-text
-version:        0.3.6.0
+version:        0.3.7.0
 synopsis:       A rope type based on a finger tree over UTF-8 fragments
 description:    A rope data type for text, built as a finger tree over UTF-8 text
                 fragments. The package also includes utiltiy functions for breaking and

core-text/lib/Core/Text/Breaking.hs

@@ -3,6 +3,7 @@
 
 -- This is an Internal module, hidden from Haddock
 module Core.Text.Breaking (
+    breakRope,
     breakWords,
     breakLines,
     breakPieces,
@@ -142,3 +143,24 @@ intoChunks predicate piece =
      in if trailing
             then intoRope chunk : emptyRope : []
             else intoRope chunk : intoChunks predicate remainder'
+
+{-
+The utilities breakPieces and its helpers above were written long before this
+code. The special purpose functions above might have been written more easily
+if this below had been written first, but they _are_ special cases and they're
+done, so {shrug} if someone wants to unify these go right head, otherwise this
+can stand as almost but not-quite repetition.
+-}
+
+{- |
+Given a piece of 'Rope' and a predicate, break the text into two pieces at the first
+site where that predicate returns 'True'.
+
+@since 0.3.7
+-}
+breakRope :: (Char -> Bool) -> Rope -> (Rope, Rope)
+breakRope predicate text =
+    let possibleIndex = findIndexRope predicate text
+     in case possibleIndex of
+            Nothing -> (text, emptyRope)
+            Just i -> splitRope i text

core-text/lib/Core/Text/Rope.hs

@@ -79,6 +79,7 @@ module Core.Text.Rope (
     replicateRope,
     replicateChar,
     widthRope,
+    unconsRope,
     splitRope,
     takeRope,
     insertRope,
@@ -154,7 +155,7 @@ import qualified Data.Text.Short as S (
     splitAt,
     toBuilder,
     toText,
-    unpack,
+    unpack, uncons
  )
 import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe)
 import GHC.Generics (Generic)
@@ -332,6 +333,24 @@ nullRope (Rope x) = case F.viewl x of
     F.EmptyL -> True
     (F.:<) piece _ -> S.null piece
 
+{- |
+Read the first character from a 'Rope', assuming it's length 1 or greater,
+returning 'Just' that character and the remainder of the text. Returns
+'Nothing' if the input is 0 length.
+
+@since 0.3.7
+-}
+unconsRope :: Rope -> Maybe (Char, Rope)
+unconsRope text =
+    let x = unRope text
+     in case F.viewl x of
+            F.EmptyL -> Nothing
+            (F.:<) piece x' ->
+                case S.uncons piece of
+                    Nothing -> Nothing
+                    Just (c, piece') -> Just (c, Rope ((F.<|) piece' x'))
+
+
 {- |
 Break the text into two pieces at the specified offset.
 

core-text/lib/Core/Text/Utilities.hs

@@ -21,6 +21,7 @@ module Core.Text.Utilities (
     -- * Helpers
     indefinite,
     oxford,
+    breakRope,
     breakWords,
     breakLines,
     breakPieces,

core-text/package.yaml

@@ -1,5 +1,5 @@
 name: core-text
-version: 0.3.6.0
+version: 0.3.7.0
 synopsis: A rope type based on a finger tree over UTF-8 fragments
 description: |
   A rope data type for text, built as a finger tree over UTF-8 text