-- |
-- Module      : Crypto.Store.Utf8
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- UTF-8 encoding and decoding.  This implementation preserves surrogates and
-- does not use the replacement character.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Crypto.Store.Utf8
    ( stringFromUTF8, stringToUTF8
    ) where

import           Data.Bits
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import           Data.Char (chr, ord)
import           Data.Word

-- | Convert a string to UTF-8 encoding.
stringToUTF8 :: String -> ByteString
stringToUTF8 :: String -> ByteString
stringToUTF8 = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Word8] -> [Word8]) -> [Word8] -> String -> [Word8]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> [Word8] -> [Word8]
charToUtf8 []

charToUtf8 :: Char -> [Word8] -> [Word8]
charToUtf8 :: Char -> [Word8] -> [Word8]
charToUtf8 Char
c [Word8]
list
    | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
0x80     = [Word8]
encode1
    | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
0x800    = [Word8]
encode2
    | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
0x10000  = [Word8]
encode3
    | Word
x Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
0x110000 = [Word8]
encode4
    | Bool
otherwise    = String -> [Word8]
forall a. HasCallStack => String -> a
error (String
"charToUtf8: invalid code point: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
x)
  where
    !x :: Word
x = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word

    encode1 :: [Word8]
encode1 = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
list
    encode2 :: [Word8]
encode2 =
        let !x1 :: Word8
x1 = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
6 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
0xc0)
            !x2 :: Word8
x2 = Word -> Word8
toC Word
x
         in Word8
x1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
list
    encode3 :: [Word8]
encode3 =
        let !x1 :: Word8
x1 = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
12 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
0xe0)
            !x2 :: Word8
x2 = Word -> Word8
toC (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
6)
            !x3 :: Word8
x3 = Word -> Word8
toC Word
x
         in Word8
x1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x3 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
list
    encode4 :: [Word8]
encode4 =
        let !x1 :: Word8
x1 = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
18 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
0xf0)
            !x2 :: Word8
x2 = Word -> Word8
toC (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
12)
            !x3 :: Word8
x3 = Word -> Word8
toC (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftR Word
x Int
6)
            !x4 :: Word8
x4 = Word -> Word8
toC Word
x
         in Word8
x1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x3 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
x4 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
list

    toC :: Word -> Word8
    toC :: Word -> Word8
toC Word
w = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
w Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
0x80)

-- | Convert a string from UTF-8 encoding.  When not fully valid, also return
-- the bytes that have not been converted.
stringFromUTF8 :: ByteString -> (String, ByteString)
stringFromUTF8 :: ByteString -> (String, ByteString)
stringFromUTF8 ByteString
bs = (String -> String) -> Int -> (String, ByteString)
go String -> String
forall a. a -> a
id Int
0
  where
    len :: Int
len = ByteString -> Int
B.length ByteString
bs

    go :: (String -> String) -> Int -> (String, ByteString)
    go :: (String -> String) -> Int -> (String, ByteString)
go String -> String
f Int
i
        | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = (String -> String
f String
"", ByteString
B.empty)
        | Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 =
            let w :: Word
w = Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x1
             in Word -> (String -> String) -> Int -> (String, ByteString)
next Word
w String -> String
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| Word8 -> Bool
invalid Word8
x2 = (String -> String) -> Int -> (String, ByteString)
end String -> String
f Int
i
        | Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xc0 Bool -> Bool -> Bool
&& Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xe0 =
            let w :: Word
w = Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x1 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x1f) Int
6 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x2 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f)
             in Word -> (String -> String) -> Int -> (String, ByteString)
next Word
w String -> String
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
        | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 Bool -> Bool -> Bool
|| Word8 -> Bool
invalid Word8
x3 = (String -> String) -> Int -> (String, ByteString)
end String -> String
f Int
i
        | Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xe0 Bool -> Bool -> Bool
&& Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf0 =
            let w :: Word
w = Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x1 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x0f) Int
12 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x2 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f)  Int
6 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x3 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f)
             in Word -> (String -> String) -> Int -> (String, ByteString)
next Word
w String -> String
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
        | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
|| Word8 -> Bool
invalid Word8
x4 = (String -> String) -> Int -> (String, ByteString)
end String -> String
f Int
i
        | Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xf0 Bool -> Bool -> Bool
&& Word8
x1 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0xf8 =
            let w :: Word
w = Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x1 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x07) Int
18 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x2 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f) Int
12 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    Word -> Int -> Word
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x3 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f)  Int
6 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
                    (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x4 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x3f)
             in Word -> (String -> String) -> Int -> (String, ByteString)
next Word
w String -> String
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
        | Bool
otherwise = (String -> String) -> Int -> (String, ByteString)
end String -> String
f Int
i

      where
        remaining :: Int
remaining = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
        x1 :: Word8
x1 = ByteString -> Int -> Word8
B.unsafeIndex ByteString
bs Int
i
        x2 :: Word8
x2 = ByteString -> Int -> Word8
B.unsafeIndex ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        x3 :: Word8
x3 = ByteString -> Int -> Word8
B.unsafeIndex ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
        x4 :: Word8
x4 = ByteString -> Int -> Word8
B.unsafeIndex ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

    end :: (String -> String) -> Int -> (String, ByteString)
    end :: (String -> String) -> Int -> (String, ByteString)
end String -> String
f !Int
i = (String -> String
f String
"", Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs)

    next :: Word -> (String -> String) -> Int -> (String, ByteString)
    next :: Word -> (String -> String) -> Int -> (String, ByteString)
next Word
w String -> String
f Int
i = let !c :: Char
c = Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w) in (String -> String) -> Int -> (String, ByteString)
go (String -> String
f (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)) Int
i

    invalid :: Word8 -> Bool
    invalid :: Word8 -> Bool
invalid Word8
x = Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x80 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xc0