json.writer: support escaping unicode > 0x10000. Thanks @jonenst!

diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor
index c43840d7f87511ee25fe78d32b2ebe2a72e69c65..bceaa7b21a5ba8e3a27e2e6d871c73ee00169b33 100644 (file)
--- a/basis/json/writer/writer-tests.factor
+++ b/basis/json/writer/writer-tests.factor
@@ -68,3 +68,6 @@ TUPLE: person first-name age ;
     "\0\x01\x02\x03\x04\x05\x06\a\b\t\n\v\f\r\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\e\x1c\x1d\x1e\x1f"
     >json
 ] unit-test
+
+{ "\"\\ud834\\udd1e\"" }
+[ t json-escape-unicode? [ "𝄞" >json ] with-variable ] unit-test

diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor
index 7a6771e02bee158c422475b309da799aa7faeb92..d91f3d781756a7da5e13c30e5567063c79dd9af6 100644 (file)
--- a/basis/json/writer/writer.factor
+++ b/basis/json/writer/writer.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs combinators fry hashtables io
-io.streams.string json kernel locals math math.parser mirrors
-namespaces sequences strings tr words ;
+USING: accessors ascii assocs combinators formatting fry
+hashtables io io.encodings.utf16.private io.streams.string json
+kernel locals math math.parser mirrors namespaces sequences
+strings tr words ;
 IN: json.writer
 
 SYMBOL: json-allow-fp-special?
@@ -39,6 +40,26 @@ M: t stream-json-print
 M: json-null stream-json-print
     [ drop "null" ] [ stream-write ] bi* ;
 
+<PRIVATE
+
+: json-print-generic-escape-surrogate-pair ( stream char -- stream )
+    0x10000 - [ encode-first ] [ encode-second ] bi
+    "\\u%x%x\\u%x%x" sprintf over stream-write ;
+
+: json-print-generic-escape-bmp ( stream char -- stream )
+    "\\u" pick stream-write
+    >hex 4 CHAR: 0 pad-head
+    over stream-write ;
+
+: json-print-generic-escape ( stream char -- stream )
+    dup 0xffff > [
+        json-print-generic-escape-surrogate-pair
+    ] [
+        json-print-generic-escape-bmp
+    ] if ;
+
+PRIVATE>
+
 M: string stream-json-print
     CHAR: " over stream-write1 swap [
         {
@@ -62,10 +83,7 @@ M: string stream-json-print
                     { [ dup control? ] [ t ] }
                     [ json-escape-unicode? get ]
                 } cond [
-                    dup 0xffff > [ json-error ] when
-                    "\\u" pick stream-write
-                    >hex 4 CHAR: 0 pad-head
-                    over stream-write
+                    json-print-generic-escape
                 ] [
                     over stream-write1
                 ] if