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 (lookup cp codePageMap)
  57
  58 buildEncoding :: CodePageArrays -> TextEncoding
  59 buildEncoding SingleByteCP {decoderArray = dec, encoderArray = enc}
  60   = TextEncoding {
  61     mkTextDecoder = return $ simpleCodec
  62         $ decodeFromSingleByte dec
  63     , mkTextEncoder = return $ simpleCodec $ encodeToSingleByte enc
  64     }
  65
  66 simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
  67                 -> BufferCodec from to ()
  68 simpleCodec f = BufferCodec {encode = f, close = return (), getState = return (),
  69                                     setState = return }
  70
  71 decodeFromSingleByte :: ConvArray Char -> DecodeBuffer
  72 decodeFromSingleByte convArr
  73     input@Buffer  { bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
  74     output@Buffer { bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  75   = let
  76         done !ir !ow = return (if ir==iw then input{ bufL=0, bufR=0}
  77                                             else input{ bufL=ir},
  78                                     output {bufR=ow})
  79         loop !ir !ow
  80             | ow >= os  || ir >= iw     = done ir ow
  81             | otherwise = do
  82                 b <- readWord8Buf iraw ir
  83                 let c = lookupConv convArr b
  84                 if c=='\0' && b /= 0 then invalid else do
  85                 ow' <- writeCharBuf oraw ow c
  86                 loop (ir+1) ow'
  87           where
  88             invalid = if ir > ir0 then done ir ow else ioe_decodingError
  89     in loop ir0 ow0
  90
  91 encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer
  92 encodeToSingleByte CompactArray { encoderMax = maxChar,
  93                          encoderIndices = indices,
  94                          encoderValues = values }
  95     input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }
  96     output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
  97   = let
  98         done !ir !ow = return (if ir==iw then input { bufL=0, bufR=0 }
  99                                             else input { bufL=ir },
 100                                 output {bufR=ow})
 101         loop !ir !ow
 102             | ow >= os || ir >= iw  = done ir ow
 103             | otherwise = do
 104                 (c,ir') <- readCharBuf iraw ir
 105                 case lookupCompact maxChar indices values c of
 106                     Nothing -> invalid
 107                     Just 0 | c /= '\0' -> invalid
 108                     Just b -> do
 109                         writeWord8Buf oraw ow b
 110                         loop ir' (ow+1)
 111             where
 112                 invalid = if ir > ir0 then done ir ow else ioe_encodingError
 113     in
 114     loop ir0 ow0
 115
 116 ioe_decodingError :: IO a
 117 ioe_decodingError = ioException
 118     (IOError Nothing InvalidArgument "codePageEncoding"
 119         "invalid code page byte sequence" Nothing Nothing)
 120
 121 ioe_encodingError :: IO a
 122 ioe_encodingError = ioException
 123     (IOError Nothing InvalidArgument "codePageEncoding"
 124         "character is not in the code page" Nothing Nothing)
 125
 126
 127 --------------------------------------------
 128 -- Array access functions
 129
 130 -- {-# INLINE lookupConv #-}
 131 lookupConv :: ConvArray Char -> Word8 -> Char
 132 lookupConv a = indexChar a . fromEnum
 133
 134 {-# INLINE lookupCompact #-}
 135 lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8
 136 lookupCompact maxVal indexes values x
 137     | x > maxVal = Nothing
 138     | otherwise = Just $ indexWord8 values $ j + (i .&. mask)
 139   where
 140     i = fromEnum x
 141     mask = (1 `shiftL` n) - 1
 142     k = i `shiftR` n
 143     j = indexInt indexes k
 144     n = blockBitSize
 145
 146 {-# INLINE indexInt #-}
 147 indexInt :: ConvArray Int -> Int -> Int
 148 indexInt (ConvArray p) (I# i) = I# (indexInt16OffAddr# p i)
 149
 150 {-# INLINE indexWord8 #-}
 151 indexWord8 :: ConvArray Word8 -> Int -> Word8
 152 indexWord8 (ConvArray p) (I# i) = W8# (indexWord8OffAddr# p i)
 153
 154 {-# INLINE indexChar #-}
 155 indexChar :: ConvArray Char -> Int -> Char
 156 indexChar (ConvArray p) (I# i) = C# (chr# (indexInt16OffAddr# p i))
 157
 158 #endif