Use explicit language extensions & remove extension fields from base.cabal
[ghc.git] / libraries / base / 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