GHC/IO/Encoding/UTF32.hs

   1 {-# OPTIONS_GHC  -XNoImplicitPrelude -funbox-strict-fields #-}
   2 {-# LANGUAGE BangPatterns #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Encoding.UTF32
   6 -- Copyright   :  (c) The University of Glasgow, 2009
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  libraries@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable
  12 --
  13 -- UTF-32 Codecs for the IO library
  14 --
  15 -- Portions Copyright   : (c) Tom Harper 2008-2009,
  16 --                        (c) Bryan O'Sullivan 2009,
  17 --                        (c) Duncan Coutts 2009
  18 --
  19 -----------------------------------------------------------------------------
  20
  21 module GHC.IO.Encoding.UTF32 (
  22   utf32,
  23   utf32_decode,
  24   utf32_encode,
  25
  26   utf32be,
  27   utf32be_decode,
  28   utf32be_encode,
  29
  30   utf32le,
  31   utf32le_decode,
  32   utf32le_encode,
  33   ) where
  34
  35 import GHC.Base
  36 import GHC.Real
  37 import GHC.Num
  38 -- import GHC.IO
  39 import GHC.IO.Exception
  40 import GHC.IO.Buffer
  41 import GHC.IO.Encoding.Types
  42 import GHC.Word
  43 import Data.Bits
  44 import Data.Maybe
  45 import GHC.IORef
  46
  47 -- -----------------------------------------------------------------------------
  48 -- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM
  49
  50 utf32  :: TextEncoding
  51 utf32 = TextEncoding { textEncodingName = "UTF-32",
  52                        mkTextDecoder = utf32_DF,
  53                        mkTextEncoder = utf32_EF }
  54
  55 utf32_DF :: IO (TextDecoder (Maybe DecodeBuffer))
  56 utf32_DF = do
  57   seen_bom <- newIORef Nothing
  58   return (BufferCodec {
  59              encode   = utf32_decode seen_bom,
  60              close    = return (),
  61              getState = readIORef seen_bom,
  62              setState = writeIORef seen_bom
  63           })
  64
  65 utf32_EF :: IO (TextEncoder Bool)
  66 utf32_EF = do
  67   done_bom <- newIORef False
  68   return (BufferCodec {
  69              encode   = utf32_encode done_bom,
  70              close    = return (),
  71              getState = readIORef done_bom,
  72              setState = writeIORef done_bom
  73           })
  74
  75 utf32_encode :: IORef Bool -> EncodeBuffer
  76 utf32_encode done_bom input
  77   output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }
  78  = do
  79   b <- readIORef done_bom
  80   if b then utf32_native_encode input output
  81        else if os - ow < 4
  82                then return (input,output)
  83                else do
  84                     writeIORef done_bom True
  85                     writeWord8Buf oraw ow     bom0
  86                     writeWord8Buf oraw (ow+1) bom1
  87                     writeWord8Buf oraw (ow+2) bom2
  88                     writeWord8Buf oraw (ow+3) bom3
  89                     utf32_native_encode input output{ bufR = ow+4 }
  90
  91 utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer
  92 utf32_decode seen_bom
  93   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }
  94   output
  95  = do
  96    mb <- readIORef seen_bom
  97    case mb of
  98      Just decode -> decode input output
  99      Nothing ->
 100        if iw - ir < 4 then return (input,output) else do
 101        c0 <- readWord8Buf iraw ir
 102        c1 <- readWord8Buf iraw (ir+1)
 103        c2 <- readWord8Buf iraw (ir+2)
 104        c3 <- readWord8Buf iraw (ir+3)
 105        case () of
 106         _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do
 107                writeIORef seen_bom (Just utf32be_decode)
 108                utf32be_decode input{ bufL= ir+4 } output
 109         _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do
 110                writeIORef seen_bom (Just utf32le_decode)
 111                utf32le_decode input{ bufL= ir+4 } output
 112           | otherwise -> do
 113                writeIORef seen_bom (Just utf32_native_decode)
 114                utf32_native_decode input output
 115
 116
 117 bom0, bom1, bom2, bom3 :: Word8
 118 bom0 = 0
 119 bom1 = 0
 120 bom2 = 0xfe
 121 bom3 = 0xff
 122
 123 -- choose UTF-32BE by default for UTF-32 output
 124 utf32_native_decode :: DecodeBuffer
 125 utf32_native_decode = utf32be_decode
 126
 127 utf32_native_encode :: EncodeBuffer
 128 utf32_native_encode = utf32be_encode
 129
 130 -- -----------------------------------------------------------------------------
 131 -- UTF32LE and UTF32BE
 132
 133 utf32be :: TextEncoding
 134 utf32be = TextEncoding { textEncodingName = "UTF-32BE",
 135                          mkTextDecoder = utf32be_DF,
 136                          mkTextEncoder = utf32be_EF }
 137
 138 utf32be_DF :: IO (TextDecoder ())
 139 utf32be_DF =
 140   return (BufferCodec {
 141              encode   = utf32be_decode,
 142              close    = return (),
 143              getState = return (),
 144              setState = const $ return ()
 145           })
 146
 147 utf32be_EF :: IO (TextEncoder ())
 148 utf32be_EF =
 149   return (BufferCodec {
 150              encode   = utf32be_encode,
 151              close    = return (),
 152              getState = return (),
 153              setState = const $ return ()
 154           })
 155
 156
 157 utf32le :: TextEncoding
 158 utf32le = TextEncoding { textEncodingName = "UTF-32LE",
 159                          mkTextDecoder = utf32le_DF,
 160                          mkTextEncoder = utf32le_EF }
 161
 162 utf32le_DF :: IO (TextDecoder ())
 163 utf32le_DF =
 164   return (BufferCodec {
 165              encode   = utf32le_decode,
 166              close    = return (),
 167              getState = return (),
 168              setState = const $ return ()
 169           })
 170
 171 utf32le_EF :: IO (TextEncoder ())
 172 utf32le_EF =
 173   return (BufferCodec {
 174              encode   = utf32le_encode,
 175              close    = return (),
 176              getState = return (),
 177              setState = const $ return ()
 178           })
 179
 180
 181 utf32be_decode :: DecodeBuffer
 182 utf32be_decode
 183   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 184   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 185  = let
 186        loop !ir !ow
 187          | ow >= os || iw - ir < 4 =  done ir ow
 188          | otherwise = do
 189               c0 <- readWord8Buf iraw ir
 190               c1 <- readWord8Buf iraw (ir+1)
 191               c2 <- readWord8Buf iraw (ir+2)
 192               c3 <- readWord8Buf iraw (ir+3)
 193               let x1 = chr4 c0 c1 c2 c3
 194               if not (validate x1) then invalid else do
 195               ow' <- writeCharBuf oraw ow x1
 196               loop (ir+4) ow'
 197          where
 198            invalid = if ir > ir0 then done ir ow else ioe_decodingError
 199
 200        -- lambda-lifted, to avoid thunks being built in the inner-loop:
 201        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 202                                           else input{ bufL=ir },
 203                          output{ bufR=ow })
 204     in
 205     loop ir0 ow0
 206
 207 utf32le_decode :: DecodeBuffer
 208 utf32le_decode
 209   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 210   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 211  = let
 212        loop !ir !ow
 213          | ow >= os || iw - ir < 4 =  done ir ow
 214          | otherwise = do
 215               c0 <- readWord8Buf iraw ir
 216               c1 <- readWord8Buf iraw (ir+1)
 217               c2 <- readWord8Buf iraw (ir+2)
 218               c3 <- readWord8Buf iraw (ir+3)
 219               let x1 = chr4 c3 c2 c1 c0
 220               if not (validate x1) then invalid else do
 221               ow' <- writeCharBuf oraw ow x1
 222               loop (ir+4) ow'
 223          where
 224            invalid = if ir > ir0 then done ir ow else ioe_decodingError
 225
 226        -- lambda-lifted, to avoid thunks being built in the inner-loop:
 227        done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 228                                           else input{ bufL=ir },
 229                          output{ bufR=ow })
 230     in
 231     loop ir0 ow0
 232
 233 ioe_decodingError :: IO a
 234 ioe_decodingError = ioException
 235      (IOError Nothing InvalidArgument "utf32_decode"
 236           "invalid UTF-32 byte sequence" Nothing Nothing)
 237
 238 utf32be_encode :: EncodeBuffer
 239 utf32be_encode
 240   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 241   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 242  = let
 243       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 244                                          else input{ bufL=ir },
 245                              output{ bufR=ow })
 246       loop !ir !ow
 247         | ir >= iw     =  done ir ow
 248         | os - ow < 4  =  done ir ow
 249         | otherwise = do
 250            (c,ir') <- readCharBuf iraw ir
 251            let (c0,c1,c2,c3) = ord4 c
 252            writeWord8Buf oraw ow     c0
 253            writeWord8Buf oraw (ow+1) c1
 254            writeWord8Buf oraw (ow+2) c2
 255            writeWord8Buf oraw (ow+3) c3
 256            loop ir' (ow+4)
 257     in
 258     loop ir0 ow0
 259
 260 utf32le_encode :: EncodeBuffer
 261 utf32le_encode
 262   input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
 263   output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
 264  = let
 265       done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 }
 266                                          else input{ bufL=ir },
 267                              output{ bufR=ow })
 268       loop !ir !ow
 269         | ir >= iw     =  done ir ow
 270         | os - ow < 4  =  done ir ow
 271         | otherwise = do
 272            (c,ir') <- readCharBuf iraw ir
 273            let (c0,c1,c2,c3) = ord4 c
 274            writeWord8Buf oraw ow     c3
 275            writeWord8Buf oraw (ow+1) c2
 276            writeWord8Buf oraw (ow+2) c1
 277            writeWord8Buf oraw (ow+3) c0
 278            loop ir' (ow+4)
 279     in
 280     loop ir0 ow0
 281
 282 chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
 283 chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
 284     C# (chr# (z1# +# z2# +# z3# +# z4#))
 285     where
 286       !y1# = word2Int# x1#
 287       !y2# = word2Int# x2#
 288       !y3# = word2Int# x3#
 289       !y4# = word2Int# x4#
 290       !z1# = uncheckedIShiftL# y1# 24#
 291       !z2# = uncheckedIShiftL# y2# 16#
 292       !z3# = uncheckedIShiftL# y3# 8#
 293       !z4# = y4#
 294 {-# INLINE chr4 #-}
 295
 296 ord4 :: Char -> (Word8,Word8,Word8,Word8)
 297 ord4 c = (fromIntegral (x `shiftR` 24),
 298           fromIntegral (x `shiftR` 16),
 299           fromIntegral (x `shiftR` 8),
 300           fromIntegral x)
 301   where
 302     x = ord c
 303 {-# INLINE ord4 #-}
 304
 305
 306 validate    :: Char -> Bool
 307 validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)
 308    where x1 = ord c
 309 {-# INLINE validate #-}