GHC/IO/Encoding/UTF32.hs

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