{-# OPTIONS_HADDOCK not-home #-}

-- | Detection of the encoding of the input.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.Input
  ( decodeInput
  ) where

import Data.Bits
import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BS
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error qualified as T
import Data.Text.Unsafe qualified as T

import Yamlet.Error
import Yamlet.Internal.Syntax
import Yamlet.Internal.Utils

-- | Decode the bytes of a stream to text. The encoding is UTF-8, UTF-16 or
-- UTF-32, detected as the YAML specification describes.
decodeInput :: BS.ByteString -> Either Error T.Text
decodeInput :: ByteString -> Either Error Text
decodeInput ByteString
bs = case (Int -> Maybe Word8) -> [Int] -> [Maybe Word8]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Int -> Maybe Word8
BS.indexMaybe ByteString
bs) [Int
0 .. Int
3] of
  [Just Word8
0, Just Word8
0, Just Word8
0xFE, Just Word8
0xFF] -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf32 OnDecodeError -> ByteString -> Text
T.decodeUtf32BEWith ByteString -> Int -> Int
be32 (Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs)
  [Just Word8
0xFF, Just Word8
0xFE, Just Word8
0, Just Word8
0] -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf32 OnDecodeError -> ByteString -> Text
T.decodeUtf32LEWith ByteString -> Int -> Int
le32 (Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs)
  [Just Word8
0xFE, Just Word8
0xFF, Maybe Word8
_, Maybe Word8
_] -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf16 OnDecodeError -> ByteString -> Text
T.decodeUtf16BEWith ByteString -> Int -> Int
be16 (Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
bs)
  [Just Word8
0xFF, Just Word8
0xFE, Maybe Word8
_, Maybe Word8
_] -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf16 OnDecodeError -> ByteString -> Text
T.decodeUtf16LEWith ByteString -> Int -> Int
le16 (Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
bs)
  [Just Word8
0, Just Word8
0, Just Word8
0, Just Word8
_] -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf32 OnDecodeError -> ByteString -> Text
T.decodeUtf32BEWith ByteString -> Int -> Int
be32 ByteString
bs
  [Just Word8
x, Just Word8
0, Just Word8
0, Just Word8
0] | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0 -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf32 OnDecodeError -> ByteString -> Text
T.decodeUtf32LEWith ByteString -> Int -> Int
le32 ByteString
bs
  Just Word8
0 : Just Word8
_ : [Maybe Word8]
_ -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf16 OnDecodeError -> ByteString -> Text
T.decodeUtf16BEWith ByteString -> Int -> Int
be16 ByteString
bs
  Just Word8
x : Just Word8
0 : [Maybe Word8]
_ | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0 -> (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf16 OnDecodeError -> ByteString -> Text
T.decodeUtf16LEWith ByteString -> Int -> Int
le16 ByteString
bs
  [Maybe Word8]
_ -> Either Error Text
utf8
  where
    utf32
      :: (T.OnDecodeError -> BS.ByteString -> T.Text)
      -> (BS.ByteString -> Int -> Int)
      -> BS.ByteString
      -> Either Error T.Text
    utf32 :: (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf32 OnDecodeError -> ByteString -> Text
decodeWith ByteString -> Int -> Int
unit ByteString
input = String
-> (OnDecodeError -> ByteString -> Text)
-> ByteString
-> Int
-> Either Error Text
checked String
"invalid UTF-32" OnDecodeError -> ByteString -> Text
decodeWith ByteString
input (Int -> Int
go Int
0)
      where
        go :: Int -> Int
        go :: Int -> Int
go Int
i
          | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
BS.length ByteString
input = Int
i
          | Int -> Bool
isScalarValue Int
c = Int -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
          | Bool
otherwise = Int
i
          where
            c :: Int
            c :: Int
c = ByteString -> Int -> Int
unit ByteString
input Int
i
    -- Inlining gives a loop for each reading function. Without it, the decode
    -- of a large UTF-32 input was slower and allocated more.
    {-# INLINE utf32 #-}

    utf16
      :: (T.OnDecodeError -> BS.ByteString -> T.Text)
      -> (BS.ByteString -> Int -> Int)
      -> BS.ByteString
      -> Either Error T.Text
    utf16 :: (OnDecodeError -> ByteString -> Text)
-> (ByteString -> Int -> Int) -> ByteString -> Either Error Text
utf16 OnDecodeError -> ByteString -> Text
decodeWith ByteString -> Int -> Int
unit ByteString
input = String
-> (OnDecodeError -> ByteString -> Text)
-> ByteString
-> Int
-> Either Error Text
checked String
"invalid UTF-16" OnDecodeError -> ByteString -> Text
decodeWith ByteString
input (Int -> Int
go Int
0)
      where
        go :: Int -> Int
        go :: Int -> Int
go Int
i
          | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
BS.length ByteString
input = Int
i
          | Int -> Bool
isHighSurrogate Int
u =
              if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ByteString -> Int
BS.length ByteString
input Bool -> Bool -> Bool
&& Int -> Bool
isLowSurrogate (ByteString -> Int -> Int
unit ByteString
input (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
                then Int -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                else Int
i
          | Int -> Bool
isLowSurrogate Int
u = Int
i
          | Bool
otherwise = Int -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
          where
            u :: Int
            u :: Int
u = ByteString -> Int -> Int
unit ByteString
input Int
i
    -- Inlining gives a loop for each reading function. Without it, the decode
    -- of a large UTF-16 input was slower and allocated more.
    {-# INLINE utf16 #-}

    -- The code unit at the index. The callers make sure that its bytes are in
    -- the input.
    be16, le16, be32, le32 :: BS.ByteString -> Int -> Int
    be16 :: ByteString -> Int -> Int
be16 ByteString
input Int
i = ByteString -> Int -> Int
byte ByteString
input Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ByteString -> Int -> Int
byte ByteString
input (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    le16 :: ByteString -> Int -> Int
le16 ByteString
input Int
i = ByteString -> Int -> Int
byte ByteString
input (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ByteString -> Int -> Int
byte ByteString
input Int
i
    be32 :: ByteString -> Int -> Int
be32 ByteString
input Int
i = ByteString -> Int -> Int
be16 ByteString
input Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ByteString -> Int -> Int
be16 ByteString
input (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    le32 :: ByteString -> Int -> Int
le32 ByteString
input Int
i = ByteString -> Int -> Int
le16 ByteString
input (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ByteString -> Int -> Int
le16 ByteString
input Int
i

    byte :: BS.ByteString -> Int -> Int
    byte :: ByteString -> Int -> Int
byte ByteString
input Int
i = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.unsafeIndex ByteString
input Int
i)

    -- The text, or an error at the end of the valid prefix of the given length.
    checked
      :: String
      -> (T.OnDecodeError -> BS.ByteString -> T.Text)
      -> BS.ByteString
      -> Int
      -> Either Error T.Text
    checked :: String
-> (OnDecodeError -> ByteString -> Text)
-> ByteString
-> Int
-> Either Error Text
checked String
msg OnDecodeError -> ByteString -> Text
decodeWith ByteString
input Int
valid
      | Int
valid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
BS.length ByteString
input = Text -> Either Error Text
forall a b. b -> Either a b
Right (Text -> Either Error Text) -> Text -> Either Error Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeWith OnDecodeError
T.lenientDecode ByteString
input
      | Bool
otherwise = Error -> Either Error Text
forall a b. a -> Either a b
Left (Error -> Either Error Text) -> Error -> Either Error Text
forall a b. (a -> b) -> a -> b
$ Text -> Offset -> String -> Error
errorAt Text
prefix (Int -> Offset
Offset (Text -> Int
T.lengthWord8 Text
prefix)) String
msg
      where
        prefix :: T.Text
        prefix :: Text
prefix = OnDecodeError -> ByteString -> Text
decodeWith OnDecodeError
T.lenientDecode (Int -> ByteString -> ByteString
BS.take Int
valid ByteString
input)

    utf8 :: Either Error T.Text
    utf8 :: Either Error Text
utf8 = case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
bs of
      Right Text
t -> Text -> Either Error Text
forall a b. b -> Either a b
Right Text
t
      Left UnicodeException
_ ->
        -- The length of the longest valid prefix.
        let valid :: Int
valid = (Int, Maybe Utf8State) -> Int
forall a b. (a, b) -> a
fst (ByteString -> (Int, Maybe Utf8State)
T.validateUtf8Chunk ByteString
bs)
            prefix :: Text
prefix = ByteString -> Text
T.decodeUtf8 (Int -> ByteString -> ByteString
BS.take Int
valid ByteString
bs)
        in Error -> Either Error Text
forall a b. a -> Either a b
Left (Error -> Either Error Text) -> Error -> Either Error Text
forall a b. (a -> b) -> a -> b
$ Text -> Offset -> String -> Error
errorAt Text
prefix (Int -> Offset
Offset Int
valid) String
"invalid UTF-8"