Utf8.hs

-- |
-- 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 = B.pack . foldr charToUtf8 []

charToUtf8 :: Char -> [Word8] -> [Word8]
charToUtf8 c list
    | x < 0x80     = encode1
    | x < 0x800    = encode2
    | x < 0x10000  = encode3
    | x < 0x110000 = encode4
    | otherwise    = error ("charToUtf8: invalid code point: " ++ show x)
  where
    !x = fromIntegral (ord c) :: Word

    encode1 = fromIntegral x : list
    encode2 =
        let !x1 = fromIntegral (unsafeShiftR x 6 .|. 0xc0)
            !x2 = toC x
         in x1 : x2 : list
    encode3 =
        let !x1 = fromIntegral (unsafeShiftR x 12 .|. 0xe0)
            !x2 = toC (unsafeShiftR x 6)
            !x3 = toC x
         in x1 : x2 : x3 : list
    encode4 =
        let !x1 = fromIntegral (unsafeShiftR x 18 .|. 0xf0)
            !x2 = toC (unsafeShiftR x 12)
            !x3 = toC (unsafeShiftR x 6)
            !x4 = toC x
         in x1 : x2 : x3 : x4 : list

    toC :: Word -> Word8
    toC w = fromIntegral ((w .&. 0x3f) .|. 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 bs = go id 0
  where
    len = B.length bs

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

      where
        remaining = len - i
        x1 = B.unsafeIndex bs i
        x2 = B.unsafeIndex bs (i + 1)
        x3 = B.unsafeIndex bs (i + 2)
        x4 = B.unsafeIndex bs (i + 3)

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

    next :: Word -> (String -> String) -> Int -> (String, ByteString)
    next w f i = let !c = chr (fromIntegral w) in go (f . (c :)) i

    invalid :: Word8 -> Bool
    invalid x = x < 0x80 || x >= 0xc0