git.iko.soy/rowtype-yoga/purescript-native
on 838dc61 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/PSString.hs
197 lines 6.9 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Language.PureScript.PSString
4 ( PSString
5 , toUTF16CodeUnits
6 , decodeString
7 , decodeStringEither
8 , decodeStringWithReplacement
9 , prettyPrintString
10 , prettyPrintStringJS
11 , mkString
12 ) where
14import Prelude.Compat
15import Control.Exception (try, evaluate)
16import Control.Applicative ((<|>))
17import Data.Char (chr)
18import Data.Bits (shiftR)
19import Data.List (unfoldr)
20import Data.Monoid ((<>))
21import Data.Scientific (toBoundedInteger)
22import Data.String (IsString(..))
23import Data.ByteString (ByteString)
24import qualified Data.ByteString as BS
25import Data.Text (Text)
26import qualified Data.Text as T
27import Data.Text.Encoding (decodeUtf16BE)
28import Data.Text.Encoding.Error (UnicodeException)
29import qualified Data.Vector as V
30import Data.Word (Word16, Word8)
31import Numeric (showHex)
32import System.IO.Unsafe (unsafePerformIO)
33import qualified Data.Aeson as A
34import qualified Data.Aeson.Types as A
36-- |
37-- Strings in PureScript are sequences of UTF-16 code units, which do not
38-- necessarily represent UTF-16 encoded text. For example, it is permissible
39-- for a string to contain *lone surrogates,* i.e. characters in the range
40-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
41--
42-- The Show instance for PSString produces a string literal which would
43-- represent the same data were it inserted into a PureScript source file.
44--
45-- Because JSON parsers vary wildly in terms of how they deal with lone
46-- surrogates in JSON strings, the ToJSON instance for PSString produces JSON
47-- strings where that would be safe (i.e. when there are no lone surrogates),
48-- and arrays of UTF-16 code units (integers) otherwise.
49--
50newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
51 deriving (Eq, Ord, Monoid)
53instance Show PSString where
54 show = show . codePoints
56-- |
57-- Decode a PSString to a String, representing any lone surrogates as the
58-- reserved code point with that index. Warning: if there are any lone
59-- surrogates, converting the result to Text via Data.Text.pack will result in
60-- loss of information as those lone surrogates will be replaced with U+FFFD
61-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
62-- we do not export it.
63--
64codePoints :: PSString -> String
65codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
67-- |
68-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with
69-- U+FFFD REPLACEMENT CHARACTER
70--
71decodeStringWithReplacement :: PSString -> String
72decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither
74-- |
75-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
76-- the output with the Left constructor; characters which were successfully
77-- decoded are represented with the Right constructor.
78--
79decodeStringEither :: PSString -> [Either Word16 Char]
80decodeStringEither = unfoldr decode . toUTF16CodeUnits
81 where
82 decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
83 decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest)
84 decode (c:rest) | isSurrogate c = Just (Left c, rest)
85 decode (c:rest) = Just (Right (toChar c), rest)
86 decode [] = Nothing
88 unsurrogate :: Word16 -> Word16 -> Char
89 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
91-- |
92-- Pretty print a PSString, using Haskell/PureScript escape sequences.
93-- This is identical to the Show instance except that we get a Text out instead
94-- of a String.
95--
96prettyPrintString :: PSString -> Text
97prettyPrintString = T.pack . show
99-- |
100-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
101-- Nothing) if the argument contains lone surrogates.
102--
103decodeString :: PSString -> Maybe Text
104decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
105 where
106 unpair w = [highByte w, lowByte w]
108 lowByte :: Word16 -> Word8
109 lowByte = fromIntegral
111 highByte :: Word16 -> Word8
112 highByte = fromIntegral . (`shiftR` 8)
114 -- Based on a similar function from Data.Text.Encoding for utf8. This is a
115 -- safe usage of unsafePerformIO because there are no side effects after
116 -- handling any thrown UnicodeExceptions.
117 decodeEither :: ByteString -> Either UnicodeException Text
118 decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE
120 hush = either (const Nothing) Just
122instance IsString PSString where
123 fromString a = PSString $ concatMap encodeUTF16 a
124 where
125 surrogates :: Char -> (Word16, Word16)
126 surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))
127 where (h, l) = divMod (fromEnum c - 0x10000) 0x400
129 encodeUTF16 :: Char -> [Word16]
130 encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]
131 where (high, low) = surrogates c
132 encodeUTF16 c = [toWord $ fromEnum c]
134instance A.ToJSON PSString where
135 toJSON str =
136 case decodeString str of
137 Just t -> A.toJSON t
138 Nothing -> A.toJSON (toUTF16CodeUnits str)
140instance A.FromJSON PSString where
141 parseJSON a = jsonString <|> arrayOfCodeUnits
142 where
143 jsonString = fromString <$> A.parseJSON a
145 arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a
147 parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
148 parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
150 parseCodeUnit :: A.Value -> A.Parser Word16
151 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
153-- |
154-- Pretty print a PSString, using JavaScript escape sequences. Intended for
155-- use in compiled JS output.
156--
157prettyPrintStringJS :: PSString -> Text
158prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
159 where
160 encodeChar :: Word16 -> Text
161 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
162 encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
163 encodeChar c | toChar c == '\b' = "\\b"
164 encodeChar c | toChar c == '\t' = "\\t"
165 encodeChar c | toChar c == '\n' = "\\n"
166 encodeChar c | toChar c == '\v' = "\\v"
167 encodeChar c | toChar c == '\f' = "\\f"
168 encodeChar c | toChar c == '\r' = "\\r"
169 encodeChar c | toChar c == '"' = "\\\""
170 encodeChar c | toChar c == '\\' = "\\\\"
171 encodeChar c = T.singleton $ toChar c
173 hex :: (Enum a) => Int -> a -> Text
174 hex width c =
175 let hs = showHex (fromEnum c) "" in
176 T.pack (replicate (width - length hs) '0' <> hs)
178isLead :: Word16 -> Bool
179isLead h = h >= 0xD800 && h <= 0xDBFF
181isTrail :: Word16 -> Bool
182isTrail l = l >= 0xDC00 && l <= 0xDFFF
184isSurrogate :: Word16 -> Bool
185isSurrogate c = isLead c || isTrail c
187toChar :: Word16 -> Char
188toChar = toEnum . fromIntegral
190toWord :: Int -> Word16
191toWord = fromIntegral
193toInt :: Word16 -> Int
194toInt = fromIntegral
196mkString :: Text -> PSString
197mkString = fromString . T.unpack