GHC/IO/Encoding/UTF32.hs

{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
 , BangPatterns
 , NondecreasingIndentation
 , MagicHash
 #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-----------------------------------------------------------------------------
-- |
-- Module : GHC.IO.Encoding.UTF32
-- Copyright : (c) The University of Glasgow, 2009
-- License : see libraries/base/LICENSE
-- 
-- Maintainer : libraries@haskell.org
-- Stability : internal
-- Portability : non-portable
--
-- UTF-32 Codecs for the IO library
--
-- Portions Copyright : (c) Tom Harper 2008-2009,
-- (c) Bryan O'Sullivan 2009,
-- (c) Duncan Coutts 2009
--
-----------------------------------------------------------------------------

module GHC.IO.Encoding.UTF32 (
 utf32, mkUTF32,
 utf32_decode,
 utf32_encode,

 utf32be, mkUTF32be,
 utf32be_decode,
 utf32be_encode,

 utf32le, mkUTF32le,
 utf32le_decode,
 utf32le_encode,
 ) where

import GHC.Base
import GHC.Real
import GHC.Num
-- import GHC.IO
import GHC.IO.Buffer
import GHC.IO.Encoding.Failure
import GHC.IO.Encoding.Types
import GHC.Word
import Data.Bits
import Data.Maybe
import GHC.IORef

-- -----------------------------------------------------------------------------
-- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM

utf32 :: TextEncoding
utf32 = mkUTF32 ErrorOnCodingFailure

-- | /Since: 4.4.0.0/
mkUTF32 :: CodingFailureMode -> TextEncoding
mkUTF32 cfm = TextEncoding { textEncodingName = "UTF-32",
 mkTextDecoder = utf32_DF cfm,
 mkTextEncoder = utf32_EF cfm }

utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer))
utf32_DF cfm = do
 seen_bom <- newIORef Nothing
 return (BufferCodec {
 encode = utf32_decode seen_bom,
 recover = recoverDecode cfm,
 close = return (),
 getState = readIORef seen_bom,
 setState = writeIORef seen_bom
 })

utf32_EF :: CodingFailureMode -> IO (TextEncoder Bool)
utf32_EF cfm = do
 done_bom <- newIORef False
 return (BufferCodec {
 encode = utf32_encode done_bom,
 recover = recoverEncode cfm,
 close = return (),
 getState = readIORef done_bom,
 setState = writeIORef done_bom
 })

utf32_encode :: IORef Bool -> EncodeBuffer
utf32_encode done_bom input
 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
 = do
 b <- readIORef done_bom
 if b then utf32_native_encode input output
 else if os - ow < 4
 then return (OutputUnderflow, input,output)
 else do
 writeIORef done_bom True
 writeWord8Buf oraw ow bom0
 writeWord8Buf oraw (ow+1) bom1
 writeWord8Buf oraw (ow+2) bom2
 writeWord8Buf oraw (ow+3) bom3
 utf32_native_encode input output{ bufR = ow+4 }

utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
utf32_decode seen_bom
 input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ }
 output
 = do
 mb <- readIORef seen_bom
 case mb of
 Just decode -> decode input output
 Nothing ->
 if iw - ir < 4 then return (InputUnderflow, input,output) else do
 c0 <- readWord8Buf iraw ir
 c1 <- readWord8Buf iraw (ir+1)
 c2 <- readWord8Buf iraw (ir+2)
 c3 <- readWord8Buf iraw (ir+3)
 case () of
 _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do
 writeIORef seen_bom (Just utf32be_decode)
 utf32be_decode input{ bufL= ir+4 } output
 _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do
 writeIORef seen_bom (Just utf32le_decode)
 utf32le_decode input{ bufL= ir+4 } output
 | otherwise -> do
 writeIORef seen_bom (Just utf32_native_decode)
 utf32_native_decode input output


bom0, bom1, bom2, bom3 :: Word8
bom0 = 0
bom1 = 0
bom2 = 0xfe
bom3 = 0xff

-- choose UTF-32BE by default for UTF-32 output
utf32_native_decode :: DecodeBuffer
utf32_native_decode = utf32be_decode

utf32_native_encode :: EncodeBuffer
utf32_native_encode = utf32be_encode

-- -----------------------------------------------------------------------------
-- UTF32LE and UTF32BE

utf32be :: TextEncoding
utf32be = mkUTF32be ErrorOnCodingFailure

-- | /Since: 4.4.0.0/
mkUTF32be :: CodingFailureMode -> TextEncoding
mkUTF32be cfm = TextEncoding { textEncodingName = "UTF-32BE",
 mkTextDecoder = utf32be_DF cfm,
 mkTextEncoder = utf32be_EF cfm }

utf32be_DF :: CodingFailureMode -> IO (TextDecoder ())
utf32be_DF cfm =
 return (BufferCodec {
 encode = utf32be_decode,
 recover = recoverDecode cfm,
 close = return (),
 getState = return (),
 setState = const $ return ()
 })

utf32be_EF :: CodingFailureMode -> IO (TextEncoder ())
utf32be_EF cfm =
 return (BufferCodec {
 encode = utf32be_encode,
 recover = recoverEncode cfm,
 close = return (),
 getState = return (),
 setState = const $ return ()
 })


utf32le :: TextEncoding
utf32le = mkUTF32le ErrorOnCodingFailure

-- | /Since: 4.4.0.0/
mkUTF32le :: CodingFailureMode -> TextEncoding
mkUTF32le cfm = TextEncoding { textEncodingName = "UTF-32LE",
 mkTextDecoder = utf32le_DF cfm,
 mkTextEncoder = utf32le_EF cfm }

utf32le_DF :: CodingFailureMode -> IO (TextDecoder ())
utf32le_DF cfm =
 return (BufferCodec {
 encode = utf32le_decode,
 recover = recoverDecode cfm,
 close = return (),
 getState = return (),
 setState = const $ return ()
 })

utf32le_EF :: CodingFailureMode -> IO (TextEncoder ())
utf32le_EF cfm =
 return (BufferCodec {
 encode = utf32le_encode,
 recover = recoverEncode cfm,
 close = return (),
 getState = return (),
 setState = const $ return ()
 })


utf32be_decode :: DecodeBuffer
utf32be_decode 
 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
 = let 
 loop !ir !ow
 | ow >= os = done OutputUnderflow ir ow
 | iw - ir < 4 = done InputUnderflow ir ow
 | otherwise = do
 c0 <- readWord8Buf iraw ir
 c1 <- readWord8Buf iraw (ir+1)
 c2 <- readWord8Buf iraw (ir+2)
 c3 <- readWord8Buf iraw (ir+3)
 let x1 = chr4 c0 c1 c2 c3
 if not (validate x1) then invalid else do
 ow' <- writeCharBuf oraw ow x1
 loop (ir+4) ow'
 where
 invalid = done InvalidSequence ir ow

 -- lambda-lifted, to avoid thunks being built in the inner-loop:
 done why !ir !ow = return (why,
 if ir == iw then input{ bufL=0, bufR=0 }
 else input{ bufL=ir },
 output{ bufR=ow })
 in
 loop ir0 ow0

utf32le_decode :: DecodeBuffer
utf32le_decode 
 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
 = let 
 loop !ir !ow
 | ow >= os = done OutputUnderflow ir ow
 | iw - ir < 4 = done InputUnderflow ir ow
 | otherwise = do
 c0 <- readWord8Buf iraw ir
 c1 <- readWord8Buf iraw (ir+1)
 c2 <- readWord8Buf iraw (ir+2)
 c3 <- readWord8Buf iraw (ir+3)
 let x1 = chr4 c3 c2 c1 c0
 if not (validate x1) then invalid else do
 ow' <- writeCharBuf oraw ow x1
 loop (ir+4) ow'
 where
 invalid = done InvalidSequence ir ow

 -- lambda-lifted, to avoid thunks being built in the inner-loop:
 done why !ir !ow = return (why,
 if ir == iw then input{ bufL=0, bufR=0 }
 else input{ bufL=ir },
 output{ bufR=ow })
 in
 loop ir0 ow0

utf32be_encode :: EncodeBuffer
utf32be_encode
 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
 = let 
 done why !ir !ow = return (why,
 if ir == iw then input{ bufL=0, bufR=0 }
 else input{ bufL=ir },
 output{ bufR=ow })
 loop !ir !ow
 | ir >= iw = done InputUnderflow ir ow
 | os - ow < 4 = done OutputUnderflow ir ow
 | otherwise = do
 (c,ir') <- readCharBuf iraw ir
 if isSurrogate c then done InvalidSequence ir ow else do
 let (c0,c1,c2,c3) = ord4 c
 writeWord8Buf oraw ow c0
 writeWord8Buf oraw (ow+1) c1
 writeWord8Buf oraw (ow+2) c2
 writeWord8Buf oraw (ow+3) c3
 loop ir' (ow+4)
 in
 loop ir0 ow0

utf32le_encode :: EncodeBuffer
utf32le_encode
 input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
 output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os }
 = let
 done why !ir !ow = return (why,
 if ir == iw then input{ bufL=0, bufR=0 }
 else input{ bufL=ir },
 output{ bufR=ow })
 loop !ir !ow
 | ir >= iw = done InputUnderflow ir ow
 | os - ow < 4 = done OutputUnderflow ir ow
 | otherwise = do
 (c,ir') <- readCharBuf iraw ir
 if isSurrogate c then done InvalidSequence ir ow else do
 let (c0,c1,c2,c3) = ord4 c
 writeWord8Buf oraw ow c3
 writeWord8Buf oraw (ow+1) c2
 writeWord8Buf oraw (ow+2) c1
 writeWord8Buf oraw (ow+3) c0
 loop ir' (ow+4)
 in
 loop ir0 ow0

chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
 C# (chr# (z1# +# z2# +# z3# +# z4#))
 where
 !y1# = word2Int# x1#
 !y2# = word2Int# x2#
 !y3# = word2Int# x3#
 !y4# = word2Int# x4#
 !z1# = uncheckedIShiftL# y1# 24#
 !z2# = uncheckedIShiftL# y2# 16#
 !z3# = uncheckedIShiftL# y3# 8#
 !z4# = y4#
{-# INLINE chr4 #-}

ord4 :: Char -> (Word8,Word8,Word8,Word8)
ord4 c = (fromIntegral (x `shiftR` 24), 
 fromIntegral (x `shiftR` 16), 
 fromIntegral (x `shiftR` 8),
 fromIntegral x)
 where
 x = ord c
{-# INLINE ord4 #-}


validate :: Char -> Bool
validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)
 where x1 = ord c
{-# INLINE validate #-}