Generate PSString values as JSON strings where possible

hdgarrood · hdgarrood · commit f478e2f5ae59 · 2017-01-05T00:05:40.000Z
Also generate records as JSON objects in the corefn JSON where possible.
This means although the the JSON format change in the next release is
strictly a breaking change, the majority of code can still be processed
without changing corefn parsers.
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -9,6 +9,7 @@ module Language.PureScript.CoreFn.ToJSON
 
 import Prelude.Compat
 
+import Data.Maybe (fromMaybe)
 import Data.Aeson
 import Data.Version (Version, showVersion)
 import Data.Text (Text)
@@ -17,7 +18,7 @@ import qualified Data.Text as T
 import Language.PureScript.AST.Literals
 import Language.PureScript.CoreFn
 import Language.PureScript.Names
-import Language.PureScript.PSString (PSString)
+import Language.PureScript.PSString (PSString, decodeString)
 
 literalToJSON :: (a -> Value) -> Literal a -> Value
 literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
@@ -52,8 +53,17 @@ bindToJSON :: Bind a -> Value
 bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]
 bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs
 
+-- If all of the labels in the record can safely be converted to JSON strings,
+-- we generate a JSON object. Otherwise the labels must be represented as
+-- arrays of integers in the JSON, and in this case we generate the record as
+-- an array of pairs.
 recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value
-recordToJSON f = toJSON . map (\(key, a) -> (toJSON key, f a))
+recordToJSON f rec = fromMaybe (asArrayOfPairs rec) (asObject rec)
+  where
+  asObject = fmap object . traverse (uncurry maybePair)
+  maybePair label a = fmap (\l -> l .= f a) (decodeString label)
+
+  asArrayOfPairs = toJSON . map (\(label, a) -> (toJSON label, f a))
 
 exprToJSON :: Expr a -> Value
 exprToJSON (Var _ i)              = toJSON ( "Var"
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
@@ -41,6 +41,11 @@ import qualified Data.Aeson.Types as A
 -- The Show instance for PSString produces a string literal which would
 -- represent the same data were it inserted into a PureScript source file.
 --
+-- Because JSON parsers vary wildly in terms of how they deal with lone
+-- surrogates in JSON strings, the ToJSON instance for PSString produces JSON
+-- strings where that would be safe (i.e. when there are no lone surrogates),
+-- and arrays of UTF-16 code units (integers) otherwise.
+--
 newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
   deriving (Eq, Ord, Monoid)
 
@@ -117,23 +122,24 @@ instance IsString PSString where
     encodeUTF16 c = [toWord $ fromEnum c]
 
 instance A.ToJSON PSString where
-  toJSON = A.toJSON . toUTF16CodeUnits
+  toJSON str =
+    case decodeString str of
+      Just t -> A.toJSON t
+      Nothing -> A.toJSON (toUTF16CodeUnits str)
 
 instance A.FromJSON PSString where
-  parseJSON a = currentParser <|> backwardsCompat
+  parseJSON a = jsonString <|> arrayOfCodeUnits
     where
-    currentParser = PSString <$> parseArrayOfCodeUnits a
+    jsonString = fromString <$> A.parseJSON a
+
+    arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a
 
     parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
     parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
 
     parseCodeUnit :: A.Value -> A.Parser Word16
     parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
 
-    -- For backwards compatibility: this allows us to parse JSON produced by
-    -- 0.10.4 or earlier
-    backwardsCompat = fromString <$> A.parseJSON a
-
 -- |
 -- Pretty print a PSString, using JavaScript escape sequences. Intended for
 -- use in compiled JS output.
