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