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