GHC/IO/Encoding/CodePage.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 module GHC.IO.Encoding.CodePage(
   3 #if !defined(mingw32_HOST_OS)
   4  ) where
   5 #else
   6                         codePageEncoding,
   7                         localeEncoding
   8                             ) where
   9
  10 import GHC.Base
  11 import GHC.Num
  12 import GHC.Enum
  13 import GHC.Word
  14 import GHC.IO (unsafePerformIO)
  15 import GHC.IO.Encoding.Types
  16 import GHC.IO.Buffer
  17 import GHC.IO.Exception
  18 import Data.Bits
  19 import Data.Maybe
  20 import Data.List (lookup)
  21
  22 import GHC.IO.Encoding.CodePage.Table
  23
  24 import GHC.IO.Encoding.Latin1 (latin1)
  25 import GHC.IO.Encoding.UTF8 (utf8)
  26 import GHC.IO.Encoding.UTF16 (utf16le, utf16be)
  27 import GHC.IO.Encoding.UTF32 (utf32le, utf32be)
  28
  29 -- note CodePage = UInt which might not work on Win64.  But the Win32 package
  30 -- also has this issue.
  31 getCurrentCodePage :: IO Word32
  32 getCurrentCodePage = do
  33     conCP <- getConsoleCP
  34     if conCP > 0
  35         then return conCP
  36         else getACP
  37
  38 -- Since the Win32 package depends on base, we have to import these ourselves:
  39 foreign import stdcall unsafe "windows.h GetConsoleCP"
  40     getConsoleCP :: IO Word32
  41
  42 foreign import stdcall unsafe "windows.h GetACP"
  43     getACP :: IO Word32
  44
  45 {-# NOINLINE localeEncoding #-}
  46 localeEncoding :: TextEncoding
  47 localeEncoding = unsafePerformIO $ fmap codePageEncoding getCurrentCodePage
  48
  49
  50 codePageEncoding :: Word32 -> TextEncoding
  51 codePageEncoding 65001 = utf8
  52 codePageEncoding 1200 = utf16le
  53 codePageEncoding 1201 = utf16be
  54 codePageEncoding 12000 = utf32le
  55 codePageEncoding 12001 = utf32be
  56 codePageEncoding cp = maybe latin1 (buildEncoding cp) (lookup cp codePageMap)
  57
  58 buildEncoding :: Word32 -> CodePageArrays -> TextEncoding
  59 buildEncoding cp SingleByteCP {decoderArray = dec, encoderArray = enc}
  60   = TextEncoding {
  61     textEncodingName = "CP" ++ show cp,
  62     mkTextDecoder = return $ simpleCodec
  63         $ decodeFromSingleByte dec
  64     , mkTextEncoder = return $ simpleCodec $ encodeToSingleByte enc
  65     }
  66
  67 simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
  68                 -> BufferCodec from to ()
  69 simpleCodec f = BufferCodec {encode = f, close = return (), getState = return (),
  70                                     setState = return }
  71
  72 decodeFromSingleByte :: ConvArray Char -> DecodeBuffer
  73 decodeFromSingleByte convArr
  74     input@Buffer  { bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  75     output@Buffer { bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  76   = let
  77         done !ir !ow = return (if ir==iw then input{ bufL=0, bufR=0}
  78                                             else input{ bufL=ir},
  79                                     output {bufR=ow})
  80         loop !ir !ow
  81             | ow >= os  || ir >= iw     = done ir ow
  82             | otherwise = do
  83                 b <- readWord8Buf iraw ir
  84                 let c = lookupConv convArr b
  85                 if c=='\0' && b /= 0 then invalid else do
  86                 ow' <- writeCharBuf oraw ow c
  87                 loop (ir+1) ow'
  88           where
  89             invalid = if ir > ir0 then done ir ow else ioe_decodingError
  90     in loop ir0 ow0
  91
  92 encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer
  93 encodeToSingleByte CompactArray { encoderMax = maxChar,
  94                          encoderIndices = indices,
  95                          encoderValues = values }
  96     input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
  97     output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  98   = let
  99         done !ir !ow = return (if ir==iw then input { bufL=0, bufR=0 }
 100                                             else input { bufL=ir },
 101                                 output {bufR=ow})
 102         loop !ir !ow
 103             | ow >= os || ir >= iw  = done ir ow
 104             | otherwise = do
 105                 (c,ir') <- readCharBuf iraw ir
 106                 case lookupCompact maxChar indices values c of
 107                     Nothing -> invalid
 108                     Just 0 | c /= '\0' -> invalid
 109                     Just b -> do
 110                         writeWord8Buf oraw ow b
 111                         loop ir' (ow+1)
 112             where
 113                 invalid = if ir > ir0 then done ir ow else ioe_encodingError
 114     in
 115     loop ir0 ow0
 116
 117 ioe_decodingError :: IO a
 118 ioe_decodingError = ioException
 119     (IOError Nothing InvalidArgument "codePageEncoding"
 120         "invalid code page byte sequence" Nothing Nothing)
 121
 122 ioe_encodingError :: IO a
 123 ioe_encodingError = ioException
 124     (IOError Nothing InvalidArgument "codePageEncoding"
 125         "character is not in the code page" Nothing Nothing)
 126
 127
 128 --------------------------------------------
 129 -- Array access functions
 130
 131 -- {-# INLINE lookupConv #-}
 132 lookupConv :: ConvArray Char -> Word8 -> Char
 133 lookupConv a = indexChar a . fromEnum
 134
 135 {-# INLINE lookupCompact #-}
 136 lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8
 137 lookupCompact maxVal indexes values x
 138     | x > maxVal = Nothing
 139     | otherwise = Just $ indexWord8 values $ j + (i .&. mask)
 140   where
 141     i = fromEnum x
 142     mask = (1 `shiftL` n) - 1
 143     k = i `shiftR` n
 144     j = indexInt indexes k
 145     n = blockBitSize
 146
 147 {-# INLINE indexInt #-}
 148 indexInt :: ConvArray Int -> Int -> Int
 149 indexInt (ConvArray p) (I# i) = I# (indexInt16OffAddr# p i)
 150
 151 {-# INLINE indexWord8 #-}
 152 indexWord8 :: ConvArray Word8 -> Int -> Word8
 153 indexWord8 (ConvArray p) (I# i) = W8# (indexWord8OffAddr# p i)
 154
 155 {-# INLINE indexChar #-}
 156 indexChar :: ConvArray Char -> Int -> Char
 157 indexChar (ConvArray p) (I# i) = C# (chr# (indexInt16OffAddr# p i))
 158
 159 #endif