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