{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{- |
   Module     : Data.CharEncoding
   Copyright  : Copyright (C) 2006 Bulat Ziganshin
   License    : BSD3

   Maintainer : Bulat Ziganshin <bulatz@HotPOP.com>
   Stability  : experimental
   Portability: Hugs/GHC

Various encodings of Char as a byte sequence (Latin1, UTF-8 and so on)
-}

module Data.CharEncoding (
           -- * Char encoding (Latin-1, UTF-8 and so on)
           Encoding(..),

           latin1, latin1Encode, latin1Decode,

           utf8, utf8Encode, utf8Decode,
       )
where

import Control.Monad
import Data.Char                (ord, chr)
import Data.Bits
import Data.Word
#ifdef __GLASGOW_HASKELL__
import GHC.Base                 (unsafeChr)
#endif

-- -----------------------------------------------------------------------------
-- Data type representing Char encoding as a sequence of bytes
--   (Latin-1, UTF-8 and so on)

data Encoding m = Encoding
  { charEncodingName :: String     -- human-readable encoding name
  , charEncode :: (Encoder m) -- putByte->putChar converter working in monad `m`
  , charDecode :: (Decoder m) -- getByte->getChar converter working in monad `m`
  }

type Encoder m  =  (Int -> m ()) -> Char -> m ()
type Decoder m  =  m Int -> m Char

-- -----------------------------------------------------------------------------
-- Latin-1 encoding

latin1 :: (Monad m) => Encoding m
latin1 = Encoding "Latin-1" latin1Encode latin1Decode

latin1Encode :: (Monad m) => (Int -> m ()) -> Char -> m ()
latin1Encode putByte c  =  putByte $! (ord c)

latin1Decode :: (Monad m) => m Int -> m Char
latin1Decode getByte    =  unsafeChr `liftM` getByte

{-# INLINE latin1Encode #-}
{-# INLINE latin1Decode #-}

-- -----------------------------------------------------------------------------
-- UTF-8 encoding

utf8 :: (Monad m) => Encoding m
utf8 = Encoding "UTF-8" utf8Encode utf8Decode

-- | Convert Unicode characters to UTF-8.
utf8Encode :: (Monad m) => (Int -> m ()) -> Char -> m ()
utf8Encode putByte c | putByte `seq` c `seq` True = do
  let n = ord c
  n `seq` return ()
  case () of
    _  | n<=0x007f -> do putByte $! n
       | n<=0x07ff -> do putByte $! (0xC0 .|. ((n `shiftR` 6) .&. 0x1F))
                         putByte $! (0x80 .|. (n .&. 0x3F))
       | n<=0xffff -> do putByte $! (0xE0 .|. ((n `shiftR` 12) .&. 0x0F))
                         putByte $! (0x80 .|. ((n `shiftR` 6) .&. 0x3F))
                         putByte $! (0x80 .|. (n .&. 0x3F))
       | otherwise -> do putByte $! (0xF0 .|. (n `shiftR` 18))
                         putByte $! (0x80 .|. ((n `shiftR` 12) .&. 0x3F))
                         putByte $! (0x80 .|. ((n `shiftR` 6) .&. 0x3F))
                         putByte $! (0x80 .|. (n .&. 0x3F))

-- | Read UTF-8 encoded string of length `n` using `action` to get each byte
utf8Decode :: (Monad m) => m Int -> m Char
utf8Decode getByte = do
      ch0 <- getByte
      case () of
         _ | ch0 <= 0x7F -> do
                return $! (unsafeChr ch0)

           | ch0 <= 0xDF -> do
                ch1 <- getByte
                return $! (unsafeChr (((ch0 - 0xC0) `shiftL` 6) +
                                       (ch1 - 0x80)))
           | ch0 <= 0xEF -> do
                ch1 <- getByte
                ch2 <- getByte
                return $! (unsafeChr (((ch0 - 0xE0) `shiftL` 12) +
                                      ((ch1 - 0x80) `shiftL` 6) +
                                       (ch2 - 0x80)))
           | otherwise -> do
                ch1 <- getByte
                ch2 <- getByte
                ch3 <- getByte
                return $! (unsafeChr (((ch0 - 0xF0) `shiftL` 18) +
                                      ((ch1 - 0x80) `shiftL` 12) +
                                      ((ch2 - 0x80) `shiftL` 6) +
                                       (ch3 - 0x80)))
{-# INLINE utf8Encode #-}
{-# INLINE utf8Decode #-}

#ifndef __GLASGOW_HASKELL__
unsafeChr = chr
#endif