Correctly handle non-BMP characters

Author: andrewthad

src/Json.hs

@@ -69,7 +69,7 @@ data Value
 
 -- | Exceptions that can happen while parsing JSON. Do not pattern
 -- match on values of this type. New data constructors may be added
--- at any time.
+-- at any time without a major version bump.
 data SyntaxException
   = EmptyInput
   | ExpectedColon
@@ -322,7 +322,16 @@ encodeUtf8Char !marr !ix !c
       PM.writeByteArray marr (ix + 2)
         (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))
       pure (ix + 3)
-  | otherwise = error "encodeUtf8Char: write this"
+  | otherwise = do
+      PM.writeByteArray marr ix
+        (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 18 .|. 0b11110000))
+      PM.writeByteArray marr (ix + 1)
+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12))))
+      PM.writeByteArray marr (ix + 2)
+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))
+      PM.writeByteArray marr (ix + 3)
+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))
+      pure (ix + 4)
 
 byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString
 byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x

test/Main.hs

@@ -1,7 +1,11 @@
 {-# language LambdaCase #-}
 {-# language OverloadedStrings #-}
 
+import Data.ByteString.Short.Internal (ShortByteString(SBS))
+import Data.Bytes (Bytes)
+import Data.Primitive (ByteArray(ByteArray))
 import Data.Scientific (Scientific,scientific)
+import Data.Text.Short (ShortText)
 import Test.Tasty (defaultMain,testGroup,TestTree)
 import Test.Tasty.HUnit ((@=?))
 import Twitter100 (encodedTwitter100,byteStringTwitter100)
@@ -36,6 +40,10 @@ tests = testGroup "Tests"
       Right (J.Object (Exts.fromList [Exts.fromList [J.Member "foo" J.True, J.Member "bar" J.False]]))
       @=?
       J.decode (Bytes.fromAsciiString "{\"foo\" : true, \"bar\": false }")
+  , THU.testCase "D" $
+      Right (J.String "Smile: 😂")
+      @=?
+      J.decode (shortTextToBytes "\"Smile: 😂\"")
   , THU.testCase "Twitter100" $
       case J.decode (Bytes.fromByteArray encodedTwitter100) of
         Left _ -> fail "nope"
@@ -62,3 +70,7 @@ toAesonValue = \case
     HM.empty mbrs
   J.Array vals -> AE.Array $ Exts.fromList $ foldr
     (\x xs -> toAesonValue x : xs) [] vals
+
+shortTextToBytes :: ShortText -> Bytes
+shortTextToBytes str = case TS.toShortByteString str of
+  SBS x -> let y = ByteArray x in Bytes.fromByteArray y