{-# LANGUAGE BangPatterns  #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Safe          #-}

-- |
-- Copyright: © Oren Ben-Kiki 2007,
--            © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- UTF decoding
--
-- This really should be factored out to the standard libraries. Since it isn't
-- there, we get to tailor it exactly to our needs. We use lazy byte strings as
-- input, which should give reasonable I\/O performance when reading large
-- files. The output is a normal 'Char' list which is easy to work with and
-- should be efficient enough as long as the 'Data.YAML.Token.Parser' does its job right.
--
module Data.YAML.Token.Encoding
  ( decode
  , Encoding(..)
  ) where

import qualified Data.ByteString.Lazy       as BL
import qualified Data.ByteString.Lazy.Char8 as BLC

import           Util

-- | Denotes the /Unicode Transformation Format/ (UTF) used for serializing the YAML document
data Encoding = UTF8    -- ^ UTF-8 encoding (or ASCII)
              | UTF16LE -- ^ UTF-16 little endian
              | UTF16BE -- ^ UTF-16 big endian
              | UTF32LE -- ^ UTF-32 little endian
              | UTF32BE -- ^ UTF-32 big endian
              deriving (Encoding -> Encoding -> Bool
(Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool) -> Eq Encoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Encoding -> Encoding -> Bool
== :: Encoding -> Encoding -> Bool
$c/= :: Encoding -> Encoding -> Bool
/= :: Encoding -> Encoding -> Bool
Eq,(forall x. Encoding -> Rep Encoding x)
-> (forall x. Rep Encoding x -> Encoding) -> Generic Encoding
forall x. Rep Encoding x -> Encoding
forall x. Encoding -> Rep Encoding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Encoding -> Rep Encoding x
from :: forall x. Encoding -> Rep Encoding x
$cto :: forall x. Rep Encoding x -> Encoding
to :: forall x. Rep Encoding x -> Encoding
Generic)

-- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-")
-- as used by most programs.
instance Show Encoding where
    show :: Encoding -> String
show Encoding
UTF8    = String
"UTF-8"
    show Encoding
UTF16LE = String
"UTF-16LE"
    show Encoding
UTF16BE = String
"UTF-16BE"
    show Encoding
UTF32LE = String
"UTF-32LE"
    show Encoding
UTF32BE = String
"UTF-32BE"

-- | @since 0.2.0
instance NFData Encoding where rnf :: Encoding -> ()
rnf !Encoding
_ = ()

-- | @'decode' bytes@ automatically detects the 'Encoding' used and converts the
-- /bytes/ to Unicode characters, with byte offsets. Note the offset is for
-- past end of the character, not its beginning.
decode :: BLC.ByteString -> (Encoding, [(Int, Char)])
decode :: ByteString -> (Encoding, [(Int, Char)])
decode ByteString
text = (Encoding
encoding, Encoding -> ByteString -> [(Int, Char)]
undoEncoding Encoding
encoding ByteString
text)
  where
    encoding :: Encoding
encoding = [Word8] -> Encoding
detectEncoding ([Word8] -> Encoding) -> [Word8] -> Encoding
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BL.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BL.take Int64
4 ByteString
text

-- | @'detectEncoding' text@ examines the first few chars (bytes) of the /text/
-- to deduce the Unicode encoding used according to the YAML spec.
detectEncoding :: [Word8] -> Encoding
detectEncoding :: [Word8] -> Encoding
detectEncoding [Word8]
text = case [Word8]
text of
    Word8
0x00 : Word8
0x00 : Word8
0xFE : Word8
0xFF : [Word8]
_ -> Encoding
UTF32BE
    Word8
0x00 : Word8
0x00 : Word8
0x00 : Word8
_    : [Word8]
_ -> Encoding
UTF32BE
    Word8
0xFF : Word8
0xFE : Word8
0x00 : Word8
0x00 : [Word8]
_ -> Encoding
UTF32LE
    Word8
_    : Word8
0x00 : Word8
0x00 : Word8
0x00 : [Word8]
_ -> Encoding
UTF32LE
    Word8
0xFE : Word8
0xFF : [Word8]
_               -> Encoding
UTF16BE
    Word8
0x00 : Word8
_    : [Word8]
_               -> Encoding
UTF16BE
    Word8
0xFF : Word8
0xFE : [Word8]
_               -> Encoding
UTF16LE
    Word8
_    : Word8
0x00 : [Word8]
_               -> Encoding
UTF16LE
    Word8
0xEF : Word8
0xBB : Word8
0xBF : [Word8]
_        -> Encoding
UTF8
    [Word8]
_                             -> Encoding
UTF8

-- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode
-- characters according to the /encoding/.
undoEncoding :: Encoding -> BLC.ByteString -> [(Int, Char)]
undoEncoding :: Encoding -> ByteString -> [(Int, Char)]
undoEncoding Encoding
encoding ByteString
bytes =
  case Encoding
encoding of
    Encoding
UTF8    -> ByteString -> Int -> [(Int, Char)]
undoUTF8 ByteString
bytes Int
0
    Encoding
UTF16LE -> [(Int, Char)] -> [(Int, Char)]
combinePairs ([(Int, Char)] -> [(Int, Char)]) -> [(Int, Char)] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> [(Int, Char)]
undoUTF16LE ByteString
bytes Int
0
    Encoding
UTF16BE -> [(Int, Char)] -> [(Int, Char)]
combinePairs ([(Int, Char)] -> [(Int, Char)]) -> [(Int, Char)] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> [(Int, Char)]
undoUTF16BE ByteString
bytes Int
0
    Encoding
UTF32LE -> [(Int, Char)] -> [(Int, Char)]
forall {a}. [(a, Char)] -> [(a, Char)]
validateScalars ([(Int, Char)] -> [(Int, Char)]) -> [(Int, Char)] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> [(Int, Char)]
undoUTF32LE ByteString
bytes Int
0
    Encoding
UTF32BE -> [(Int, Char)] -> [(Int, Char)]
forall {a}. [(a, Char)] -> [(a, Char)]
validateScalars ([(Int, Char)] -> [(Int, Char)]) -> [(Int, Char)] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> [(Int, Char)]
undoUTF32BE ByteString
bytes Int
0
  where
    validateScalars :: [(a, Char)] -> [(a, Char)]
validateScalars [] = []
    validateScalars (x :: (a, Char)
x@(a
_,Char
c):[(a, Char)]
rest)
      | Char
'\xD800' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c, Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDFFF' = String -> [(a, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-32 stream contains invalid surrogate code-point"
      | Bool
otherwise                    = (a, Char)
x (a, Char) -> [(a, Char)] -> [(a, Char)]
forall a. a -> [a] -> [a]
: [(a, Char)] -> [(a, Char)]
validateScalars [(a, Char)]
rest

-- ** UTF-32 decoding

-- | @hasFewerThan bytes n@ checks whether there are fewer than /n/ /bytes/
-- left to read.
hasFewerThan :: Int -> BLC.ByteString -> Bool
hasFewerThan :: Int -> ByteString -> Bool
hasFewerThan Int
n ByteString
bytes
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = ByteString -> Bool
BLC.null ByteString
bytes
  | Int
n  Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = ByteString -> Bool
BLC.null ByteString
bytes Bool -> Bool -> Bool
|| Int -> ByteString -> Bool
hasFewerThan (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes)
  | Bool
otherwise = Bool
False

-- | @undoUTF32LE bytes offset@ decoded a UTF-32LE /bytes/ stream to Unicode
-- chars.
undoUTF32LE :: BLC.ByteString -> Int -> [(Int, Char)]
undoUTF32LE :: ByteString -> Int -> [(Int, Char)]
undoUTF32LE ByteString
bytes Int
offset
  | ByteString -> Bool
BLC.null ByteString
bytes = []
  | Int -> ByteString -> Bool
hasFewerThan Int
4 ByteString
bytes = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-32LE input contains invalid number of bytes"
  | Bool
otherwise = let first :: Char
first    = ByteString -> Char
BLC.head ByteString
bytes
                    bytes' :: ByteString
bytes'   = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes
                    second :: Char
second   = ByteString -> Char
BLC.head ByteString
bytes'
                    bytes'' :: ByteString
bytes''  = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'
                    third :: Char
third    = ByteString -> Char
BLC.head ByteString
bytes''
                    bytes''' :: ByteString
bytes''' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes''
                    fourth :: Char
fourth   = ByteString -> Char
BLC.head ByteString
bytes'''
                    rest :: ByteString
rest     = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'''
                in (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4,
                    Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$        Char -> Int
ord Char
first
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Char -> Int
ord Char
second
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Char -> Int
ord Char
third
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Char -> Int
ord Char
fourth)))(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:(ByteString -> Int -> [(Int, Char)]
undoUTF32LE ByteString
rest (Int -> [(Int, Char)]) -> Int -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)

-- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode
-- chars.
undoUTF32BE :: BLC.ByteString -> Int -> [(Int, Char)]
undoUTF32BE :: ByteString -> Int -> [(Int, Char)]
undoUTF32BE ByteString
bytes Int
offset
  | ByteString -> Bool
BLC.null ByteString
bytes = []
  | Int -> ByteString -> Bool
hasFewerThan Int
4 ByteString
bytes = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-32BE input contains invalid number of bytes"
  | Bool
otherwise = let first :: Char
first    = ByteString -> Char
BLC.head ByteString
bytes
                    bytes' :: ByteString
bytes'   = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes
                    second :: Char
second   = ByteString -> Char
BLC.head ByteString
bytes'
                    bytes'' :: ByteString
bytes''  = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'
                    third :: Char
third    = ByteString -> Char
BLC.head ByteString
bytes''
                    bytes''' :: ByteString
bytes''' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes''
                    fourth :: Char
fourth   = ByteString -> Char
BLC.head ByteString
bytes'''
                    rest :: ByteString
rest     = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'''
                in (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4,
                    Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$        Char -> Int
ord Char
fourth
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Char -> Int
ord Char
third
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Char -> Int
ord Char
second
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Char -> Int
ord Char
first)))(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:(ByteString -> Int -> [(Int, Char)]
undoUTF32BE ByteString
rest (Int -> [(Int, Char)]) -> Int -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)

-- ** UTF-16 decoding

-- | @combinePairs chars@ converts each pair of UTF-16 surrogate characters to a
-- single Unicode character.
combinePairs :: [(Int, Char)] -> [(Int, Char)]
combinePairs :: [(Int, Char)] -> [(Int, Char)]
combinePairs []                          = []
combinePairs (head' :: (Int, Char)
head'@(Int
_, Char
head_char):[(Int, Char)]
tail')
  | Char
'\xD800' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
head_char Bool -> Bool -> Bool
&& Char
head_char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDBFF' = (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
combineLead (Int, Char)
head' [(Int, Char)]
tail'
  | Char
'\xDC00' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
head_char Bool -> Bool -> Bool
&& Char
head_char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDFFF' = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-16 contains trail surrogate without lead surrogate"
  | Bool
otherwise                                      = (Int, Char)
head'(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:[(Int, Char)] -> [(Int, Char)]
combinePairs [(Int, Char)]
tail'

-- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the
-- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues
-- combining surrogate pairs.
combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
combineLead (Int, Char)
_lead []                                 = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-16 contains lead surrogate as final character"
combineLead (Int
_, Char
lead_char) ((Int
trail_offset, Char
trail_char):[(Int, Char)]
rest)
  | Char
'\xDC00' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
trail_char Bool -> Bool -> Bool
&& Char
trail_char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDFFF' = (Int
trail_offset, Char -> Char -> Char
combineSurrogates Char
lead_char Char
trail_char)(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:[(Int, Char)] -> [(Int, Char)]
combinePairs [(Int, Char)]
rest
  | Bool
otherwise                                        = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-16 contains lead surrogate without trail surrogate"

-- | @surrogateOffset@ is copied from the Unicode FAQs.
surrogateOffset :: Int
surrogateOffset :: Int
surrogateOffset = Int
0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
0xD800 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xDC00

-- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single
-- Unicode character.
combineSurrogates :: Char -> Char -> Char
combineSurrogates :: Char -> Char -> Char
combineSurrogates Char
lead Char
trail = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
lead Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
trail Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
surrogateOffset

-- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode
-- chars.
undoUTF16LE :: BLC.ByteString -> Int -> [(Int, Char)]
undoUTF16LE :: ByteString -> Int -> [(Int, Char)]
undoUTF16LE ByteString
bytes Int
offset
  | ByteString -> Bool
BLC.null ByteString
bytes = []
  | Int -> ByteString -> Bool
hasFewerThan Int
2 ByteString
bytes = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-16LE input contains odd number of bytes"
  | Bool
otherwise = let low :: Char
low    = ByteString -> Char
BLC.head ByteString
bytes
                    bytes' :: ByteString
bytes' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes
                    high :: Char
high   = ByteString -> Char
BLC.head ByteString
bytes'
                    rest :: ByteString
rest   = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'
                in (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2, Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
low Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
high Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256)(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:(ByteString -> Int -> [(Int, Char)]
undoUTF16LE ByteString
rest (Int -> [(Int, Char)]) -> Int -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

-- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode
-- chars.
undoUTF16BE :: BLC.ByteString -> Int -> [(Int, Char)]
undoUTF16BE :: ByteString -> Int -> [(Int, Char)]
undoUTF16BE ByteString
bytes Int
offset
  | ByteString -> Bool
BLC.null ByteString
bytes = []
  | Int -> ByteString -> Bool
hasFewerThan Int
2 ByteString
bytes = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-16BE input contains odd number of bytes"
  | Bool
otherwise = let high :: Char
high   = ByteString -> Char
BLC.head ByteString
bytes
                    bytes' :: ByteString
bytes' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes
                    low :: Char
low    = ByteString -> Char
BLC.head ByteString
bytes'
                    rest :: ByteString
rest   = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BLC.tail ByteString
bytes'
                in (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2, Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
low Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
high Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256)(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
:(ByteString -> Int -> [(Int, Char)]
undoUTF16BE ByteString
rest (Int -> [(Int, Char)]) -> Int -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

-- ** UTF-8 decoding

-- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars.
undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)]
undoUTF8 :: ByteString -> Int -> [(Int, Char)]
undoUTF8 ByteString
bytes = [Word8] -> Int -> [(Int, Char)]
undoUTF8' (ByteString -> [Word8]
BL.unpack ByteString
bytes)

w2c :: Word8 -> Char
w2c :: Word8 -> Char
w2c = Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

w2i :: Word8 -> Int
w2i :: Word8 -> Int
w2i = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

undoUTF8' :: [Word8] -> Int -> [(Int, Char)]
undoUTF8' :: [Word8] -> Int -> [(Int, Char)]
undoUTF8' [] Int
_ = []
undoUTF8' (Word8
first:[Word8]
rest) !Int
offset
  | Word8
first Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80  = (Int
offset', Char
c) (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
: [Word8] -> Int -> [(Int, Char)]
undoUTF8' [Word8]
rest Int
offset'
  where
    !offset' :: Int
offset' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    !c :: Char
c       = Word8 -> Char
w2c Word8
first
undoUTF8' (Word8
first:[Word8]
rest) !Int
offset
  | Word8
first Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xC0  = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 input contains invalid first byte"
  | Word8
first Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xE0  = Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeTwoUTF8   Word8
first Int
offset [Word8]
rest
  | Word8
first Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xF0  = Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeThreeUTF8 Word8
first Int
offset [Word8]
rest
  | Word8
first Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xF8  = Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeFourUTF8  Word8
first Int
offset [Word8]
rest
  | Bool
otherwise     = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 input contains invalid first byte"

-- | @decodeTwoUTF8 first offset bytes@ decodes a two-byte UTF-8 character,
-- where the /first/ byte is already available and the second is the head of
-- the /bytes/, and then continues to undo the UTF-8 encoding.
decodeTwoUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeTwoUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeTwoUTF8 Word8
first Int
offset (Word8
second:[Word8]
rest)
  | Word8
second Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
second = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 double byte char has invalid second byte"
  | Bool
otherwise = (Int
offset', Char
c) (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
: [Word8] -> Int -> [(Int, Char)]
undoUTF8' [Word8]
rest Int
offset'
  where
    !offset' :: Int
offset' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
    !c :: Char
c       = Int -> Char
chr ((Word8 -> Int
w2i Word8
first Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xc0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x40  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Word8 -> Int
w2i Word8
second Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80))
decodeTwoUTF8 Word8
_ Int
_ [] = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 double byte char is missing second byte at eof"

-- | @decodeThreeUTF8 first offset bytes@ decodes a three-byte UTF-8 character,
-- where the /first/ byte is already available and the second and third are the
-- head of the /bytes/, and then continues to undo the UTF-8 encoding.
decodeThreeUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeThreeUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeThreeUTF8 Word8
first Int
offset (Word8
second:Word8
third:[Word8]
rest)
  | Word8
second Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
second = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 triple byte char has invalid second byte"
  | Word8
third Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<  Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
third  = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 triple byte char has invalid third byte"
  | Bool
otherwise = (Int
offset', Char
c)(Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
: [Word8] -> Int -> [(Int, Char)]
undoUTF8' [Word8]
rest Int
offset'
  where
    !offset' :: Int
offset' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
    !c :: Char
c       = Int -> Char
chr((Word8 -> Int
w2i Word8
first  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xE0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                   (Word8 -> Int
w2i Word8
second Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x40 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                   (Word8 -> Int
w2i Word8
third  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80))
decodeThreeUTF8 Word8
_ Int
_ [Word8]
_ =String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 triple byte char is missing bytes at eof"

-- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character,
-- where the /first/ byte is already available and the second, third and fourth
-- are the head of the /bytes/, and then continues to undo the UTF-8 encoding.
decodeFourUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeFourUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)]
decodeFourUTF8 Word8
first Int
offset (Word8
second:Word8
third:Word8
fourth:[Word8]
rest)
  | Word8
second Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
second = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 quad byte char has invalid second byte"
  | Word8
third  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
third  = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 quad byte char has invalid third byte"
  | Word8
third  Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
0xBF Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
third  = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 quad byte char has invalid fourth byte"
  | Bool
otherwise                      = (Int
offset', Char
c) (Int, Char) -> [(Int, Char)] -> [(Int, Char)]
forall a. a -> [a] -> [a]
: [Word8] -> Int -> [(Int, Char)]
undoUTF8' [Word8]
rest Int
offset'
  where
    !offset' :: Int
offset' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
    !c :: Char
c       = Int -> Char
chr((Word8 -> Int
w2i Word8
first  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xF0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x40000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                   (Word8 -> Int
w2i Word8
second Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                   (Word8 -> Int
w2i Word8
third  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x40 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                   (Word8 -> Int
w2i Word8
fourth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x80))

decodeFourUTF8 Word8
_ Int
_ [Word8]
_ = String -> [(Int, Char)]
forall a. HasCallStack => String -> a
error String
"UTF-8 quad byte char is missing bytes at eof"