GHC/IO/Encoding/CodePage.hs

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