@@ -1,19 +1,35 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Language.PureScript.PSString (PSString, mkString, renderPSString, renderJSON, toUTF16CodeUnits, codePoints, containsLoneSurrogates) where
3+module Language.PureScript.PSString
5import Prelude.Compat
13import Prelude.Compat
6−import Numeric (showHex)
14+import Control.Exception (try, evaluate)
15+import Data.Char (chr)
16+import Data.Bits (shiftR)
7import Data.List (unfoldr)
17import Data.List (unfoldr)
8import Data.Monoid ((<>))
18import Data.Monoid ((<>))
9import Data.Scientific (toBoundedInteger)
19import Data.Scientific (toBoundedInteger)
10import Data.String (IsString(..))
20import Data.String (IsString(..))
21+import Data.ByteString (ByteString)
22+import qualified Data.ByteString as BS
11import Data.Text (Text)
23import Data.Text (Text)
24+import qualified Data.Text as T
25+import Data.Text.Encoding (decodeUtf16BE)
26+import Data.Text.Encoding.Error (UnicodeException)
27+import qualified Data.Vector as V
12−import Data.Word (Word16)
28+import Data.Word (Word16, Word8)
29+import Numeric (showHex)
30+import System.IO.Unsafe (unsafePerformIO)
13import qualified Data.Aeson as A
31import qualified Data.Aeson as A
14import qualified Data.Aeson.Types as A
32import qualified Data.Aeson.Types as A
15−import qualified Data.Vector as V
16−import qualified Data.Text as T
19-- Strings in PureScript are sequences of UTF-16 code units, which do not
35-- Strings in PureScript are sequences of UTF-16 code units, which do not
@@ -21,36 +37,71 @@ import qualified Data.Text as T
21-- for a string to contain *lone surrogates,* i.e. characters in the range
37-- for a string to contain *lone surrogates,* i.e. characters in the range
22-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
38-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
40+-- The Show instance for PSString produces a string literal which would
41+-- represent the same data were it inserted into a PureScript source file.
25−newtype PSString = PSString [Word16]
43+newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
26 deriving (Eq, Ord, Monoid)
44 deriving (Eq, Ord, Monoid)
28instance Show PSString where
46instance Show PSString where
29− show = either show show . codePoints
47+ show = show . codePoints
31−renderPSString :: PSString -> Text
49+-- Decode a PSString to a String, representing any lone surrogates as the
32−renderPSString = T.pack . either show show . codePoints
50+-- reserved code point with that index. Warning: if there are any lone
51+-- surrogates, converting the result to Text via Data.Text.pack will result in
52+-- loss of information as those lone surrogates will be replaced with U+FFFD
53+-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
54+-- we do not export it.
55+codePoints :: PSString -> String
56+codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
34−-- NOTE: lone surrogates in the given PSString are represented in the resulting
59+-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
35−-- String as the reserved code point with that index
60+-- the output with the Left constructor; characters which were successfully
36−codePoints :: PSString -> Either String Text
61+-- decoded are represented with the Right constructor.
63+decodeStringEither :: PSString -> [Either Word16 Char]
37−codePoints s = (if containsLoneSurrogates s then Left . unfoldr decode else Right . T.unfoldr decode) $ toUTF16CodeUnits s
64+decodeStringEither = unfoldr decode . toUTF16CodeUnits
39− decode :: [Word16] -> Maybe (Char, [Word16])
66+ decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
40− decode (h:l:rest) | isLead h && isTrail l = Just (unsurrogate h l, rest)
67+ decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest)
68+ decode (c:rest) | isSurrogate c = Just (Left c, rest)
41− decode (c:rest) = Just (toChar c, rest)
69+ decode (c:rest) = Just (Right (toChar c), rest)
42 decode [] = Nothing
70 decode [] = Nothing
44 unsurrogate :: Word16 -> Word16 -> Char
72 unsurrogate :: Word16 -> Word16 -> Char
45 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
73 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
47−containsLoneSurrogates :: PSString -> Bool
75+-- |
48−containsLoneSurrogates = or . unfoldr headIsLoneSurrogate . toUTF16CodeUnits
76+-- Pretty print a PSString, using Haskell/PureScript escape sequences.
77+-- This is identical to the Show instance except that we get a Text out instead
80+prettyPrintString :: PSString -> Text
81+prettyPrintString = T.pack . show
84+-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
85+-- Nothing) if the argument contains lone surrogates.
87+decodeString :: PSString -> Maybe Text
88+decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
50− headIsLoneSurrogate :: [Word16] -> Maybe (Bool, [Word16])
90+ unpair w = [highByte w, lowByte w]
51− headIsLoneSurrogate (h:l:rest) | isLead h && isTrail l = Just (False, rest)
91+
52− headIsLoneSurrogate (c:rest) = Just (isLead c || isTrail c, rest)
92+ lowByte :: Word16 -> Word8
53− headIsLoneSurrogate [] = Nothing
93+ lowByte = fromIntegral
95+ highByte :: Word16 -> Word8
96+ highByte = fromIntegral . (`shiftR` 8)
98+ -- Based on a similar function from Data.Text.Encoding for utf8. This is a
99+ -- safe usage of unsafePerformIO because there are no side effects after
100+ -- handling any thrown UnicodeExceptions.
101+ decodeEither :: ByteString -> Either UnicodeException Text
102+ decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE
104+ hush = either (const Nothing) Just
55instance IsString PSString where
106instance IsString PSString where
56 fromString a = PSString $ concatMap encodeUTF16 a
107 fromString a = PSString $ concatMap encodeUTF16 a
@@ -71,12 +122,16 @@ instance A.FromJSON PSString where
71 parseJSON a = PSString <$> parseArrayOfCodeUnits a
122 parseJSON a = PSString <$> parseArrayOfCodeUnits a
73 parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
124 parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
74− parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" $ \b -> sequence (parseCodeUnit <$> V.toList b)
125+ parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
75 parseCodeUnit :: A.Value -> A.Parser Word16
126 parseCodeUnit :: A.Value -> A.Parser Word16
76 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
127 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
130+-- Pretty print a PSString, using JavaScript escape sequences. Intended for
131+-- use in compiled JS output.
78−renderJSON :: PSString -> Text
133+prettyPrintStringJS :: PSString -> Text
79−renderJSON s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
134+prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
81 encodeChar :: Word16 -> Text
136 encodeChar :: Word16 -> Text
82 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
137 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
@@ -102,6 +157,9 @@ isLead h = h >= 0xD800 && h <= 0xDBFF
102isTrail :: Word16 -> Bool
157isTrail :: Word16 -> Bool
103isTrail l = l >= 0xDC00 && l <= 0xDFFF
158isTrail l = l >= 0xDC00 && l <= 0xDFFF
160+isSurrogate :: Word16 -> Bool
161+isSurrogate c = isLead c || isTrail c
105toChar :: Word16 -> Char
163toChar :: Word16 -> Char
106toChar = toEnum . fromIntegral
164toChar = toEnum . fromIntegral
@@ -113,6 +171,3 @@ toInt = fromIntegral
114mkString :: Text -> PSString
172mkString :: Text -> PSString
115mkString = fromString . T.unpack
173mkString = fromString . T.unpack
117−toUTF16CodeUnits :: PSString -> [Word16]
118−toUTF16CodeUnits (PSString s) = s