Fix PSString escaping when used as an object property

lib/Language/PureScript/Backend/IR.hs

@@ -5,23 +5,24 @@ module Language.PureScript.Backend.IR
 
 import Control.Monad.Error.Class (MonadError (throwError))
 import Control.Monad.Writer.Class (MonadWriter (..))
-import Data.Char qualified as Char
 import Data.Foldable (foldrM)
 import Data.List qualified as List
 import Data.List.NonEmpty ((<|))
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Lazy qualified as Map
 import Data.Tagged (Tagged (Tagged))
-import Data.Text qualified as Text
 import Data.Traversable (for)
 import Language.PureScript.Backend.IR.Types
 import Language.PureScript.CoreFn qualified as Cfn
 import Language.PureScript.CoreFn.Laziness (applyLazinessTransform)
 import Language.PureScript.Names (ModuleName (..), runModuleName)
 import Language.PureScript.Names qualified as Names
 import Language.PureScript.Names qualified as PS
-import Language.PureScript.PSString (PSString, decodeStringEither)
-import Numeric (showHex)
+import Language.PureScript.PSString
+  ( PSString
+  , decodeString
+  , decodeStringEscaping
+  )
 import Relude.Extra (toFst)
 import Relude.Unsafe qualified as Unsafe
 import Text.Pretty.Simple (pShow)
@@ -194,16 +195,15 @@ mkLiteral = \case
   Cfn.NumericLiteral (Right d) →
     pure $ literalFloat d
   Cfn.StringLiteral s →
-    pure $ literalString $ psStringToText s
+    pure $ literalString $ decodeStringEscaping s
   Cfn.CharLiteral c →
     pure $ literalChar c
   Cfn.BooleanLiteral b →
     pure $ literalBool b
   Cfn.ArrayLiteral exprs →
     literalArray <$> traverse makeExp exprs
   Cfn.ObjectLiteral kvs →
-    let props = first (PropName . psStringToText) <$> kvs
-     in literalObject <$> traverse (traverse makeExp) props
+    literalObject <$> traverse (bitraverse mkPropName makeExp) kvs
 
 mkConstructor
   ∷ Cfn.Ann
@@ -235,15 +235,20 @@ mkCtorName = CtorName . PS.runProperName
 mkFieldName ∷ PS.Ident → FieldName
 mkFieldName = FieldName . PS.runIdent
 
+mkPropName ∷ PSString → RepM PropName
+mkPropName str = case decodeString str of
+  Left err → throwContextualError $ UnicodeDecodeError err
+  Right decodedString → pure $ PropName decodedString
+
 mkAccessor ∷ PSString → CfnExp → RepM Exp
-mkAccessor prop cfnExpr =
-  makeExp cfnExpr <&> \expr → objectProp expr (PropName (psStringToText prop))
+mkAccessor prop cfnExpr = do
+  propName ← mkPropName prop
+  makeExp cfnExpr <&> \expr → objectProp expr propName
 
 mkObjectUpdate ∷ CfnExp → [(PSString, CfnExp)] → RepM Exp
 mkObjectUpdate cfnExp props = do
   expr ← makeExp cfnExp
-  patch ← for props \(prop, cExpr) →
-    (PropName (psStringToText prop),) <$> makeExp cExpr
+  patch ← traverse (bitraverse mkPropName makeExp) props
   case NE.nonEmpty patch of
     Nothing → throwContextualError EmptyObjectUpdate
     Just ps → pure $ objectUpdate expr ps
@@ -281,54 +286,6 @@ mkLet binds expr = do
       & maybe (throwContextualError LetWithoutBinds) (traverse mkGrouping)
   lets groupings <$> makeExp expr
 
-psStringToText ∷ PSString → Text
-psStringToText = foldMap encodeChar . decodeStringEither
- where
-  encodeChar ∷ Either Word16 Char → Text
-  encodeChar (Left c) = "\\x" <> showHex' 6 c
-  encodeChar (Right c)
-    | c == '\t' = "\\t"
-    | c == '\r' = "\\r"
-    | c == '\n' = "\\n"
-    | c == '"' = "\\\""
-    | c == '\'' = "\\\'"
-    | c == '\\' = "\\\\"
-    | shouldPrint c = Text.singleton c
-    | otherwise = "\\x" <> showHex' 6 (Char.ord c)
-
-  -- Note we do not use Data.Char.isPrint here because that includes things
-  -- like zero-width spaces and combining punctuation marks, which could be
-  -- confusing to print unescaped.
-  shouldPrint ∷ Char → Bool
-  -- The standard space character, U+20 SPACE, is the only space char we should
-  -- print without escaping
-  shouldPrint ' ' = True
-  shouldPrint c =
-    Char.generalCategory c
-      `elem` [ Char.UppercaseLetter
-             , Char.LowercaseLetter
-             , Char.TitlecaseLetter
-             , Char.OtherLetter
-             , Char.DecimalNumber
-             , Char.LetterNumber
-             , Char.OtherNumber
-             , Char.ConnectorPunctuation
-             , Char.DashPunctuation
-             , Char.OpenPunctuation
-             , Char.ClosePunctuation
-             , Char.InitialQuote
-             , Char.FinalQuote
-             , Char.OtherPunctuation
-             , Char.MathSymbol
-             , Char.CurrencySymbol
-             , Char.ModifierSymbol
-             , Char.OtherSymbol
-             ]
-  showHex' ∷ Enum a ⇒ Int → a → Text
-  showHex' width c =
-    let hs = showHex (fromEnum c) ""
-     in Text.pack (replicate (width - length hs) '0' <> hs)
-
 --------------------------------------------------------------------------------
 -- Case statements are compiled to a decision trees (nested if/else's) ---------
 -- The algorithm is based on this document: ------------------------------------
@@ -606,7 +563,7 @@ mkBinder matchExp = go mempty
         Cfn.NumericLiteral (Right d) →
           pure $ matchWhole $ PatFloating d
         Cfn.StringLiteral s →
-          pure $ matchWhole $ PatString (psStringToText s)
+          pure $ matchWhole $ PatString (decodeStringEscaping s)
         Cfn.CharLiteral c →
           pure $ matchWhole $ PatChar c
         Cfn.BooleanLiteral b →
@@ -625,8 +582,9 @@ mkBinder matchExp = go mempty
               }
         Cfn.ObjectLiteral kvs → do
           nestedMatches ←
-            for kvs \(PropName . psStringToText → prop, binder) →
-              go (TakeProp prop : stepsToFocus) binder
+            for kvs \(prop, binder) → do
+              propName ← mkPropName prop
+              go (TakeProp propName : stepsToFocus) binder
           pure
             Match
               { matchExp
@@ -739,6 +697,7 @@ data CoreFnErrorReason
   | TypeNotDeclared
       (Map (ModuleName, TyName) (AlgebraicType, Map CtorName [FieldName]))
       TyName
+  | UnicodeDecodeError UnicodeException
 
 instance Show CoreFnErrorReason where
   show = \case
@@ -767,3 +726,5 @@ instance Show CoreFnErrorReason where
         <> show tyName
         <> ".\n Known types: "
         <> toString (pShow decls)
+    UnicodeDecodeError e →
+      "Unicode decode error: " <> displayException e

lib/Language/PureScript/Backend/Lua.hs

@@ -164,7 +164,7 @@ fromExp foreigns topLevelNames modname ir = case ir of
     Lua.hash <$> go (IR.unAnn e)
   IR.ArrayIndex expr index →
     flip Lua.varIndex (Lua.Integer (fromIntegral index)) <$> go (IR.unAnn expr)
-  IR.ObjectProp expr propName →
+  IR.ObjectProp expr propName → do
     flip Lua.varField (fromPropName propName) <$> go (IR.unAnn expr)
   IR.ObjectUpdate expr propValues → do
     add UsesObjectUpdate
@@ -232,9 +232,9 @@ fromExp foreigns topLevelNames modname ir = case ir of
           Lua.table
             [ Lua.tableRowNV name (Lua.ForeignSourceExp src)
             | (key, src) ← toList exports
-            -- Export tables can contain Lua-reserved words as keys
+            , -- Export tables can contain Lua-reserved words as keys
             -- for example: `{ ["for"] = 42 }`
-            , let name = Key.toSafeName key
+            let name = Key.toSafeName key
             , name `elem` names
             ]
     pure case foreignHeader of

lib/Language/PureScript/PSString.hs

@@ -4,7 +4,7 @@ module Language.PureScript.PSString
   , decodeString
   , decodeStringEither
   , decodeStringWithReplacement
-  , prettyPrintString
+  , decodeStringEscaping
   , prettyPrintStringJS
   , mkString
   ) where
@@ -90,9 +90,9 @@ decodeStringEither = unfoldr decode . toUTF16CodeUnits
 Attempt to decode a PSString as UTF-16 text. This will fail (returning
 Nothing) if the argument contains lone surrogates.
 -}
-decodeString ∷ PSString → Maybe Text
+decodeString ∷ PSString → Either UnicodeException Text
 decodeString =
-  rightToMaybe . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
+  decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
  where
   unpair w = [highByte w, lowByte w]
 
@@ -124,7 +124,7 @@ instance IsString PSString where
 
 instance A.ToJSON PSString where
   toJSON str =
-    case decodeString str of
+    case rightToMaybe (decodeString str) of
       Just t → A.toJSON t
       Nothing → A.toJSON (toUTF16CodeUnits str)
 
@@ -149,10 +149,10 @@ instance A.FromJSON PSString where
         b
 
 {- |
-Pretty print a PSString, using PureScript escape sequences.
+Decode a PSString as UTF-16, using PureScript escape sequences.
 -}
-prettyPrintString ∷ PSString → Text
-prettyPrintString s = "\"" <> foldMap encodeChar (decodeStringEither s) <> "\""
+decodeStringEscaping ∷ PSString → Text
+decodeStringEscaping s = foldMap encodeChar (decodeStringEither s)
  where
   encodeChar ∷ Either Word16 Char → Text
   encodeChar (Left c) = "\\x" <> showHex' 6 c
@@ -194,7 +194,6 @@ prettyPrintString s = "\"" <> foldMap encodeChar (decodeStringEither s) <> "\""
              , Char.ModifierSymbol
              , Char.OtherSymbol
              ]
-
 {- |
 Pretty print a PSString, using JavaScript escape sequences. Intended for
 use in compiled JS output.