forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathPSString.hs
More file actions
203 lines (172 loc) · 6.84 KB
/
PSString.hs
File metadata and controls
203 lines (172 loc) · 6.84 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Language.PureScript.PSString
( PSString
, toUTF16CodeUnits
, decodeString
, decodeStringEither
, decodeStringWithReplacement
, prettyPrintString
, prettyPrintStringJS
, mkString
) where
import Prelude.Compat
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Control.Exception (try, evaluate)
import Control.Applicative ((<|>))
import Data.Char (chr)
import Data.Bits (shiftR)
import Data.List (unfoldr)
import Data.Monoid ((<>))
import Data.Scientific (toBoundedInteger)
import Data.String (IsString(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf16BE)
import Data.Text.Encoding.Error (UnicodeException)
import qualified Data.Vector as V
import Data.Word (Word16, Word8)
import Numeric (showHex)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
-- |
-- Strings in PureScript are sequences of UTF-16 code units, which do not
-- necessarily represent UTF-16 encoded text. For example, it is permissible
-- for a string to contain *lone surrogates,* i.e. characters in the range
-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
--
-- 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, Generic)
instance NFData PSString
instance Show PSString where
show = show . codePoints
-- |
-- Decode a PSString to a String, representing any lone surrogates as the
-- reserved code point with that index. Warning: if there are any lone
-- surrogates, converting the result to Text via Data.Text.pack will result in
-- loss of information as those lone surrogates will be replaced with U+FFFD
-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
-- we do not export it.
--
codePoints :: PSString -> String
codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
-- |
-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with
-- U+FFFD REPLACEMENT CHARACTER
--
decodeStringWithReplacement :: PSString -> String
decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither
-- |
-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
-- the output with the Left constructor; characters which were successfully
-- decoded are represented with the Right constructor.
--
decodeStringEither :: PSString -> [Either Word16 Char]
decodeStringEither = unfoldr decode . toUTF16CodeUnits
where
decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest)
decode (c:rest) | isSurrogate c = Just (Left c, rest)
decode (c:rest) = Just (Right (toChar c), rest)
decode [] = Nothing
unsurrogate :: Word16 -> Word16 -> Char
unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
-- |
-- Pretty print a PSString, using Haskell/PureScript escape sequences.
-- This is identical to the Show instance except that we get a Text out instead
-- of a String.
--
prettyPrintString :: PSString -> Text
prettyPrintString = T.pack . show
-- |
-- 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 = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
where
unpair w = [highByte w, lowByte w]
lowByte :: Word16 -> Word8
lowByte = fromIntegral
highByte :: Word16 -> Word8
highByte = fromIntegral . (`shiftR` 8)
-- Based on a similar function from Data.Text.Encoding for utf8. This is a
-- safe usage of unsafePerformIO because there are no side effects after
-- handling any thrown UnicodeExceptions.
decodeEither :: ByteString -> Either UnicodeException Text
decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE
hush = either (const Nothing) Just
instance IsString PSString where
fromString a = PSString $ concatMap encodeUTF16 a
where
surrogates :: Char -> (Word16, Word16)
surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))
where (h, l) = divMod (fromEnum c - 0x10000) 0x400
encodeUTF16 :: Char -> [Word16]
encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]
where (high, low) = surrogates c
encodeUTF16 c = [toWord $ fromEnum c]
instance A.ToJSON PSString where
toJSON str =
case decodeString str of
Just t -> A.toJSON t
Nothing -> A.toJSON (toUTF16CodeUnits str)
instance A.FromJSON PSString where
parseJSON a = jsonString <|> arrayOfCodeUnits
where
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
-- |
-- Pretty print a PSString, using JavaScript escape sequences. Intended for
-- use in compiled JS output.
--
prettyPrintStringJS :: PSString -> Text
prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
where
encodeChar :: Word16 -> Text
encodeChar c | c > 0xFF = "\\u" <> hex 4 c
encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
encodeChar c | toChar c == '\b' = "\\b"
encodeChar c | toChar c == '\t' = "\\t"
encodeChar c | toChar c == '\n' = "\\n"
encodeChar c | toChar c == '\v' = "\\v"
encodeChar c | toChar c == '\f' = "\\f"
encodeChar c | toChar c == '\r' = "\\r"
encodeChar c | toChar c == '"' = "\\\""
encodeChar c | toChar c == '\\' = "\\\\"
encodeChar c = T.singleton $ toChar c
hex :: (Enum a) => Int -> a -> Text
hex width c =
let hs = showHex (fromEnum c) "" in
T.pack (replicate (width - length hs) '0' <> hs)
isLead :: Word16 -> Bool
isLead h = h >= 0xD800 && h <= 0xDBFF
isTrail :: Word16 -> Bool
isTrail l = l >= 0xDC00 && l <= 0xDFFF
isSurrogate :: Word16 -> Bool
isSurrogate c = isLead c || isTrail c
toChar :: Word16 -> Char
toChar = toEnum . fromIntegral
toWord :: Int -> Word16
toWord = fromIntegral
toInt :: Word16 -> Int
toInt = fromIntegral
mkString :: Text -> PSString
mkString = fromString . T.unpack