module Language.PureScript.PSString

( PSString

, toUTF16CodeUnits

, decodeString

, decodeStringEither

, decodeStringWithReplacement

, decodeStringEscaping

, prettyPrintStringJS

, mkString

) where

import Control.Exception (evaluate, try)

import Data.Aeson qualified as A

import Data.Aeson.Types qualified as A

import Data.Bits (shiftR, (.&.), (.|.))

import Data.ByteString qualified as BS

import Data.Char qualified as Char

import Data.IntCast (intCast)

import Data.Scientific (toBoundedInteger)

import Data.Text qualified as T

import Data.Text.Encoding (decodeUtf16BE)

import Data.Vector qualified as V

import Numeric (showHex)

import System.IO.Unsafe (unsafePerformIO)

import Text.Show (Show (..))

import Prelude hiding (show)

newtype PSString = PSString {toUTF16CodeUnits ∷ [Word16]}

deriving stock (Eq, Ord, Generic)

deriving newtype (Semigroup, Monoid)

instance Show PSString where

show = show . codePoints

codePoints ∷ PSString → String

codePoints = map (either (Char.chr . intCast) id) . decodeStringEither

decodeStringWithReplacement ∷ PSString → String

decodeStringWithReplacement = map (fromRight '\xFFFD') . decodeStringEither

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

decodeString ∷ PSString → Either UnicodeException Text

decodeString =

decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits

where

unpair w = [highByte w, lowByte w]

-- Deliberate narrowing: fromIntegral keeps the low 8 bits, which is exactly

-- the low byte we want. intCast would (correctly) reject Word16 → Word8.

lowByte ∷ Word16 → Word8

lowByte = fromIntegral

-- The shiftR 8 leaves a value in 0..255, so the narrowing to Word8 is always

-- exact; intCast cannot see that bound statically, so keep 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

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 rightToMaybe (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

decodeStringEscaping ∷ PSString → Text

decodeStringEscaping s = foldMap encodeAtom (withNextDigit (decodeStringEither s))

where

-- Lua's decimal escape reads up to three digits after the backslash, so an

-- escape immediately followed by a literal digit character must be

-- zero-padded to three digits or it swallows that digit.

withNextDigit ∷ [Either Word16 Char] → [(Either Word16 Char, Bool)]

withNextDigit atoms = zip atoms (map startsWithAsciiDigit (drop 1 atoms) <> [False])

startsWithAsciiDigit ∷ Either Word16 Char → Bool

startsWithAsciiDigit (Right c) = Char.isDigit c

startsWithAsciiDigit (Left _) = False

encodeAtom ∷ (Either Word16 Char, Bool) → Text

encodeAtom (Left c, padLast) = decimalEscapes padLast (wtf8SurrogateBytes c)

encodeAtom (Right c, padLast)

| c == '\t' = "\\t"

| c == '\r' = "\\r"

| c == '\n' = "\\n"

| c == '"' = "\\\""

| c == '\'' = "\\\'"

| c == '\\' = "\\\\"

| shouldPrint c = T.singleton c

| otherwise = decimalEscapes padLast (BS.unpack (encodeUtf8 (T.singleton c)))

-- Every Lua version, including our 5.1 floor, reads a \ddd decimal escape,

-- unlike \x, which is unsupported in 5.1 and reads a different number of

-- digits in 5.2+/LuaJIT. A code point needing escape becomes one \ddd per

-- UTF-8 byte; only the last byte can abut the next character, so only it is

-- ever zero-padded.

decimalEscapes ∷ Bool → [Word8] → Text

decimalEscapes padLast bytes =

foldMap escapeByte (zip bytes (replicate (length bytes - 1) False <> [padLast]))

where

escapeByte ∷ (Word8, Bool) → Text

escapeByte (b, pad) =

let digits = show b

in "\\"

<> T.pack (if pad then replicate (3 - length digits) '0' <> digits else digits)

-- A lone surrogate has no UTF-8 encoding (it is not a valid Unicode scalar

-- value); WTF-8 extends UTF-8 by encoding it with the same 3-byte pattern

-- UTF-8 uses for any other code point in the same 0x0800-0xFFFF range.

wtf8SurrogateBytes ∷ Word16 → [Word8]

wtf8SurrogateBytes w =

[ 0xE0 .|. fromIntegral (w `shiftR` 12)

, 0x80 .|. fromIntegral ((w `shiftR` 6) .&. 0x3F)

, 0x80 .|. fromIntegral (w .&. 0x3F)

]

-- Note we do not use Data.Char.isPrint here because that includes things

-- like zero-width spaces and combining punctuation marks, which could be

-- confusing to print unescaped.

shouldPrint ∷ Char → Bool

-- The standard space character, U+20 SPACE, is the only space char we should

-- print without escaping

shouldPrint ' ' = True

shouldPrint c =

Char.generalCategory c

`elem` [ Char.UppercaseLetter

, Char.LowercaseLetter

, Char.TitlecaseLetter

, Char.OtherLetter

, Char.DecimalNumber

, Char.LetterNumber

, Char.OtherNumber

, Char.ConnectorPunctuation

, Char.DashPunctuation

, Char.OpenPunctuation

, Char.ClosePunctuation

, Char.InitialQuote

, Char.FinalQuote

, Char.OtherPunctuation

, Char.MathSymbol

, Char.CurrencySymbol

, Char.ModifierSymbol

, Char.OtherSymbol

]

prettyPrintStringJS ∷ PSString → Text

prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""

where

encodeChar ∷ Word16 → Text

encodeChar c | c > 0xFF = "\\u" <> showHex' 4 c

encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> showHex' 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

showHex' ∷ Enum a ⇒ Int → a → Text

showHex' 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 . intCast

toWord ∷ Int → Word16

toWord = fromIntegral

toInt ∷ Word16 → Int

toInt = intCast

mkString ∷ Text → PSString

mkString = fromString . T.unpack