git.iko.soy/rowtype-yoga/purescript-native
on 16c6aae help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/PSString.hs
181 lines 6.3 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--
44newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
45 deriving (Eq, Ord, Monoid)
47instance Show PSString where
48 show = show . codePoints
50-- Decode a PSString to a String, representing any lone surrogates as the
51-- reserved code point with that index. Warning: if there are any lone
52-- surrogates, converting the result to Text via Data.Text.pack will result in
53-- loss of information as those lone surrogates will be replaced with U+FFFD
54-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
55-- we do not export it.
56codePoints :: PSString -> String
57codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
59-- |
60-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
61-- the output with the Left constructor; characters which were successfully
62-- decoded are represented with the Right constructor.
63--
64decodeStringEither :: PSString -> [Either Word16 Char]
65decodeStringEither = unfoldr decode . toUTF16CodeUnits
66 where
67 decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
68 decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest)
69 decode (c:rest) | isSurrogate c = Just (Left c, rest)
70 decode (c:rest) = Just (Right (toChar c), rest)
71 decode [] = Nothing
73 unsurrogate :: Word16 -> Word16 -> Char
74 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
76-- |
77-- Pretty print a PSString, using Haskell/PureScript escape sequences.
78-- This is identical to the Show instance except that we get a Text out instead
79-- of a String.
80--
81prettyPrintString :: PSString -> Text
82prettyPrintString = T.pack . show
84-- |
85-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
86-- Nothing) if the argument contains lone surrogates.
87--
88decodeString :: PSString -> Maybe Text
89decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
90 where
91 unpair w = [highByte w, lowByte w]
93 lowByte :: Word16 -> Word8
94 lowByte = fromIntegral
96 highByte :: Word16 -> Word8
97 highByte = fromIntegral . (`shiftR` 8)
99 -- Based on a similar function from Data.Text.Encoding for utf8. This is a
100 -- safe usage of unsafePerformIO because there are no side effects after
101 -- handling any thrown UnicodeExceptions.
102 decodeEither :: ByteString -> Either UnicodeException Text
103 decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE
105 hush = either (const Nothing) Just
107instance IsString PSString where
108 fromString a = PSString $ concatMap encodeUTF16 a
109 where
110 surrogates :: Char -> (Word16, Word16)
111 surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))
112 where (h, l) = divMod (fromEnum c - 0x10000) 0x400
114 encodeUTF16 :: Char -> [Word16]
115 encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]
116 where (high, low) = surrogates c
117 encodeUTF16 c = [toWord $ fromEnum c]
119instance A.ToJSON PSString where
120 toJSON = A.toJSON . toUTF16CodeUnits
122instance A.FromJSON PSString where
123 parseJSON a = currentParser <|> backwardsCompat
124 where
125 currentParser = PSString <$> parseArrayOfCodeUnits a
127 parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
128 parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
130 parseCodeUnit :: A.Value -> A.Parser Word16
131 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
133 -- For backwards compatibility: this allows us to parse JSON produced by
134 -- 0.10.4 or earlier
135 backwardsCompat = fromString <$> A.parseJSON a
137-- |
138-- Pretty print a PSString, using JavaScript escape sequences. Intended for
139-- use in compiled JS output.
140--
141prettyPrintStringJS :: PSString -> Text
142prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
143 where
144 encodeChar :: Word16 -> Text
145 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
146 encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
147 encodeChar c | toChar c == '\b' = "\\b"
148 encodeChar c | toChar c == '\t' = "\\t"
149 encodeChar c | toChar c == '\n' = "\\n"
150 encodeChar c | toChar c == '\v' = "\\v"
151 encodeChar c | toChar c == '\f' = "\\f"
152 encodeChar c | toChar c == '\r' = "\\r"
153 encodeChar c | toChar c == '"' = "\\\""
154 encodeChar c | toChar c == '\\' = "\\\\"
155 encodeChar c = T.singleton $ toChar c
157 hex :: (Enum a) => Int -> a -> Text
158 hex width c =
159 let hs = showHex (fromEnum c) "" in
160 T.pack (replicate (width - length hs) '0' <> hs)
162isLead :: Word16 -> Bool
163isLead h = h >= 0xD800 && h <= 0xDBFF
165isTrail :: Word16 -> Bool
166isTrail l = l >= 0xDC00 && l <= 0xDFFF
168isSurrogate :: Word16 -> Bool
169isSurrogate c = isLead c || isTrail c
171toChar :: Word16 -> Char
172toChar = toEnum . fromIntegral
174toWord :: Int -> Word16
175toWord = fromIntegral
177toInt :: Word16 -> Int
178toInt = fromIntegral
180mkString :: Text -> PSString
181mkString = fromString . T.unpack