fixes purescript#2172: allow escape seqs in JS FFI exported using strings

michaelficarra · michaelficarra · commit 17c486d8256e · 2016-05-30T19:17:13.000-07:00
diff --git a/examples/passing/2172.js b/examples/passing/2172.js
@@ -0,0 +1,5 @@
+exports['a\''] = 0;
+exports["\x62\x27"] = 1;
+// NOTE: I wanted to use "\c'" here, but langauge-javascript doesn't support it...
+exports["c'"] = 2;
+exports["\u0064\u0027"] = 3;
diff --git a/examples/passing/2172.purs b/examples/passing/2172.purs
@@ -0,0 +1,10 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+foreign import a' :: Number
+foreign import b' :: Number
+foreign import c' :: Number
+foreign import d' :: Number
+
+main = log "Done"
diff --git a/purescript.cabal b/purescript.cabal
@@ -20,6 +20,7 @@ author: Phil Freeman <paf31@cantab.net>,
 tested-with: GHC==7.10.3
 
 extra-source-files: examples/passing/*.purs
+                  , examples/passing/*.js
                   , examples/passing/2018/*.purs
                   , examples/passing/2138/*.purs
                   , examples/passing/ClassRefSyntax/*.purs
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
@@ -19,6 +19,7 @@ import Prelude.Compat
 import Control.Monad
 import Control.Monad.Error.Class
 
+import Data.Char (chr, digitToInt)
 import Data.Generics (everything, everywhere, mkQ, mkT)
 import Data.Graph
 import Data.List (nub, stripPrefix)
@@ -186,11 +187,34 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
 
 -- String literals include the quote chars
 fromStringLiteral :: JSExpression -> Maybe String
-fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str
+fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str
 fromStringLiteral _ = Nothing
 
-trimStringQuotes :: String -> String
-trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str
+strValue :: String -> String
+strValue str = go $ drop 1 str
+  where
+  go ('\\' : 'b' : xs) = '\b' : go xs
+  go ('\\' : 'f' : xs) = '\f' : go xs
+  go ('\\' : 'n' : xs) = '\n' : go xs
+  go ('\\' : 'r' : xs) = '\r' : go xs
+  go ('\\' : 't' : xs) = '\t' : go xs
+  go ('\\' : 'v' : xs) = '\v' : go xs
+  go ('\\' : '0' : xs) = '\0' : go xs
+  go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
+    where
+    a' = 16 * digitToInt a
+    b' = digitToInt b
+  go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
+    where
+    a' = 16 * 16 * 16 * digitToInt a
+    b' = 16 * 16 * digitToInt b
+    c' = 16 * digitToInt c
+    d' = digitToInt d
+  go ('\\' : x : xs) = x : go xs
+  go "\"" = ""
+  go "'" = ""
+  go (x : xs) = x : go xs
+  go "" = ""
 
 commaList :: JSCommaList a -> [a]
 commaList JSLNil = []
@@ -332,7 +356,7 @@ matchExportsAssignment stmt
   = Nothing
 
 extractLabel :: JSPropertyName -> Maybe String
-extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm)
+extractLabel (JSPropertyString _ nm) = Just $ strValue nm
 extractLabel (JSPropertyIdent _ nm) = Just nm
 extractLabel _ = Nothing
 
