@@ -1,19 +1,35 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Language.PureScript.PSString (PSString, mkString, renderPSString, renderJSON, toUTF16CodeUnits, codePoints, containsLoneSurrogates) where
3+module Language.PureScript.PSString
4+ ( PSString
5+ , toUTF16CodeUnits
6+ , decodeString
7+ , decodeStringEither
8+ , prettyPrintString
9+ , prettyPrintStringJS
10+ , mkString
11+ ) where
412
513import Prelude.Compat
6−import Numeric (showHex)
14+import Control.Exception (try, evaluate)
15+import Data.Char (chr)
16+import Data.Bits (shiftR)
717import Data.List (unfoldr)
818import Data.Monoid ((<>))
919import Data.Scientific (toBoundedInteger)
1020import Data.String (IsString(..))
21+import Data.ByteString (ByteString)
22+import qualified Data.ByteString as BS
1123import Data.Text (Text)
12−import Data.Word (Word16)
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
28+import Data.Word (Word16, Word8)
29+import Numeric (showHex)
30+import System.IO.Unsafe (unsafePerformIO)
1331import qualified Data.Aeson as A
1432import qualified Data.Aeson.Types as A
15−import qualified Data.Vector as V
16−import qualified Data.Text as T
1733
1834-- |
1935-- Strings in PureScript are sequences of UTF-16 code units, which do not
@@ -21,36 +37,71 @@ import qualified Data.Text as T
2137-- for a string to contain *lone surrogates,* i.e. characters in the range
2238-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
2339--
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.
2442--
25−newtype PSString = PSString [Word16]
43+newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
2644 deriving (Eq, Ord, Monoid)
2745
2846instance Show PSString where
29− show = either show show . codePoints
47+ show = show . codePoints
3048
31−renderPSString :: PSString -> Text
32−renderPSString = T.pack . either show show . codePoints
49+-- Decode a PSString to a String, representing any lone surrogates as the
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
3357
34−-- NOTE: lone surrogates in the given PSString are represented in the resulting
35−-- String as the reserved code point with that index
36−codePoints :: PSString -> Either String Text
37−codePoints s = (if containsLoneSurrogates s then Left . unfoldr decode else Right . T.unfoldr decode) $ toUTF16CodeUnits s
58+-- |
59+-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
60+-- the output with the Left constructor; characters which were successfully
61+-- decoded are represented with the Right constructor.
62+--
63+decodeStringEither :: PSString -> [Either Word16 Char]
64+decodeStringEither = unfoldr decode . toUTF16CodeUnits
3865 where
39− decode :: [Word16] -> Maybe (Char, [Word16])
40− decode (h:l:rest) | isLead h && isTrail l = Just (unsurrogate h l, rest)
41− decode (c:rest) = Just (toChar c, rest)
66+ decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
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)
69+ decode (c:rest) = Just (Right (toChar c), rest)
4270 decode [] = Nothing
4371
4472 unsurrogate :: Word16 -> Word16 -> Char
4573 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
4674
47−containsLoneSurrogates :: PSString -> Bool
48−containsLoneSurrogates = or . unfoldr headIsLoneSurrogate . toUTF16CodeUnits
75+-- |
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
78+-- of a String.
79+--
80+prettyPrintString :: PSString -> Text
81+prettyPrintString = T.pack . show
82+
83+-- |
84+-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
85+-- Nothing) if the argument contains lone surrogates.
86+--
87+decodeString :: PSString -> Maybe Text
88+decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
4989 where
50− headIsLoneSurrogate :: [Word16] -> Maybe (Bool, [Word16])
51− headIsLoneSurrogate (h:l:rest) | isLead h && isTrail l = Just (False, rest)
52− headIsLoneSurrogate (c:rest) = Just (isLead c || isTrail c, rest)
53− headIsLoneSurrogate [] = Nothing
90+ unpair w = [highByte w, lowByte w]
91+
92+ lowByte :: Word16 -> Word8
93+ lowByte = fromIntegral
94+
95+ highByte :: Word16 -> Word8
96+ highByte = fromIntegral . (`shiftR` 8)
97+
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
103+
104+ hush = either (const Nothing) Just
54105
55106instance IsString PSString where
56107 fromString a = PSString $ concatMap encodeUTF16 a
@@ -71,12 +122,16 @@ instance A.FromJSON PSString where
71122 parseJSON a = PSString <$> parseArrayOfCodeUnits a
72123 where
73124 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)
75126 parseCodeUnit :: A.Value -> A.Parser Word16
76127 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
77128
78−renderJSON :: PSString -> Text
79−renderJSON s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
129+-- |
130+-- Pretty print a PSString, using JavaScript escape sequences. Intended for
131+-- use in compiled JS output.
132+--
133+prettyPrintStringJS :: PSString -> Text
134+prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
80135 where
81136 encodeChar :: Word16 -> Text
82137 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
@@ -102,6 +157,9 @@ isLead h = h >= 0xD800 && h <= 0xDBFF
102157isTrail :: Word16 -> Bool
103158isTrail l = l >= 0xDC00 && l <= 0xDFFF
104159
160+isSurrogate :: Word16 -> Bool
161+isSurrogate c = isLead c || isTrail c
162+
105163toChar :: Word16 -> Char
106164toChar = toEnum . fromIntegral
107165
@@ -113,6 +171,3 @@ toInt = fromIntegral
113171
114172mkString :: Text -> PSString
115173mkString = fromString . T.unpack
116−
117−toUTF16CodeUnits :: PSString -> [Word16]
118−toUTF16CodeUnits (PSString s) = s