GHC/IO/Encoding/CodePage.hs

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