git.iko.soy/rowtype-yoga/purescript-native
on 072cadd help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/PSString.hs
173 lines 6.1 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 Data.Char (chr)
16import Data.Bits (shiftR)
17import Data.List (unfoldr)
18import Data.Monoid ((<>))
19import Data.Scientific (toBoundedInteger)
20import Data.String (IsString(..))
21import Data.ByteString (ByteString)
22import qualified Data.ByteString as BS
23import Data.Text (Text)
24import qualified Data.Text as T
25import Data.Text.Encoding (decodeUtf16BE)
26import Data.Text.Encoding.Error (UnicodeException)
27import qualified Data.Vector as V
28import Data.Word (Word16, Word8)
29import Numeric (showHex)
30import System.IO.Unsafe (unsafePerformIO)
31import qualified Data.Aeson as A
32import qualified Data.Aeson.Types as A
34-- |
35-- Strings in PureScript are sequences of UTF-16 code units, which do not
36-- necessarily represent UTF-16 encoded text. For example, it is permissible
37-- for a string to contain *lone surrogates,* i.e. characters in the range
38-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
39--
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.
42--
43newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
44 deriving (Eq, Ord, Monoid)
46instance Show PSString where
47 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.
55codePoints :: PSString -> String
56codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
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--
63decodeStringEither :: PSString -> [Either Word16 Char]
64decodeStringEither = unfoldr decode . toUTF16CodeUnits
65 where
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)
70 decode [] = Nothing
72 unsurrogate :: Word16 -> Word16 -> Char
73 unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
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--
80prettyPrintString :: PSString -> Text
81prettyPrintString = T.pack . show
83-- |
84-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
85-- Nothing) if the argument contains lone surrogates.
86--
87decodeString :: PSString -> Maybe Text
88decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
89 where
90 unpair w = [highByte w, lowByte w]
92 lowByte :: Word16 -> Word8
93 lowByte = fromIntegral
95 highByte :: Word16 -> Word8
96 highByte = fromIntegral . (`shiftR` 8)
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
104 hush = either (const Nothing) Just
106instance IsString PSString where
107 fromString a = PSString $ concatMap encodeUTF16 a
108 where
109 surrogates :: Char -> (Word16, Word16)
110 surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))
111 where (h, l) = divMod (fromEnum c - 0x10000) 0x400
113 encodeUTF16 :: Char -> [Word16]
114 encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]
115 where (high, low) = surrogates c
116 encodeUTF16 c = [toWord $ fromEnum c]
118instance A.ToJSON PSString where
119 toJSON = A.toJSON . toUTF16CodeUnits
121instance A.FromJSON PSString where
122 parseJSON a = PSString <$> parseArrayOfCodeUnits a
123 where
124 parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
125 parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
126 parseCodeUnit :: A.Value -> A.Parser Word16
127 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
129-- |
130-- Pretty print a PSString, using JavaScript escape sequences. Intended for
131-- use in compiled JS output.
132--
133prettyPrintStringJS :: PSString -> Text
134prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
135 where
136 encodeChar :: Word16 -> Text
137 encodeChar c | c > 0xFF = "\\u" <> hex 4 c
138 encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
139 encodeChar c | toChar c == '\b' = "\\b"
140 encodeChar c | toChar c == '\t' = "\\t"
141 encodeChar c | toChar c == '\n' = "\\n"
142 encodeChar c | toChar c == '\v' = "\\v"
143 encodeChar c | toChar c == '\f' = "\\f"
144 encodeChar c | toChar c == '\r' = "\\r"
145 encodeChar c | toChar c == '"' = "\\\""
146 encodeChar c | toChar c == '\\' = "\\\\"
147 encodeChar c = T.singleton $ toChar c
149 hex :: (Enum a) => Int -> a -> Text
150 hex width c =
151 let hs = showHex (fromEnum c) "" in
152 T.pack (replicate (width - length hs) '0' <> hs)
154isLead :: Word16 -> Bool
155isLead h = h >= 0xD800 && h <= 0xDBFF
157isTrail :: Word16 -> Bool
158isTrail l = l >= 0xDC00 && l <= 0xDFFF
160isSurrogate :: Word16 -> Bool
161isSurrogate c = isLead c || isTrail c
163toChar :: Word16 -> Char
164toChar = toEnum . fromIntegral
166toWord :: Int -> Word16
167toWord = fromIntegral
169toInt :: Word16 -> Int
170toInt = fromIntegral
172mkString :: Text -> PSString
173mkString = fromString . T.unpack