2 This is a script to generate the necessary tables to support Windows code page
5 License: see libraries/base/LICENSE
7 The code page tables are available from :
8 http://www.unicode.org/Public/MAPPINGS/
10 To run this script, use e.g.
11 runghc MakeTable.hs <module-name> <output-file> <codepage-dir>/*.TXT
13 Currently, this script only supports single-byte encodings, since the lookup
14 tables required for the CJK double-byte codepages are too large to be
15 statically linked into every executable. We plan to add support for them once
16 GHC is able to produce Windows DLLs.
22 import System.FilePath
23 import qualified Data.Map as Map
25 import Data.Maybe (mapMaybe)
26 import Data.List (intersperse)
29 import Control.Monad.State
30 import System.Environment
31 import Control.Exception(evaluate)
35 moduleName:outFile:files <- getArgs
36 let badFiles = -- These fail with an error like
37 -- MakeTable: Enum.toEnum{Word8}: tag (33088) is outside of bounds (0,255)
38 -- I have no idea what's going on, so for now we just
44 let files' = filter (`notElem` badFiles) files
45 sbes <- mapM readMapAndIx files'
46 putStrLn "Writing output"
47 withBinaryFile outFile WriteMode $ flip hPutStr
48 $ unlines $ makeTableFile moduleName files' sbes
51 putStrLn ("Reading " ++ f)
53 return (codePageNum f, m)
55 -- filenames are assumed to be of the form "CP1250.TXT"
56 codePageNum :: FilePath -> Int
57 codePageNum = read . drop 2 . takeBaseName
59 readMap :: (Ord a, Enum a) => FilePath -> IO (Map.Map a Char)
60 readMap f = withBinaryFile f ReadMode $ \h -> do
61 contents <- hGetContents h
62 let ms = Map.fromList $ mapMaybe parseLine $ lines contents
63 evaluate $ Map.size ms
66 parseLine :: Enum a => String -> Maybe (a,Char)
67 parseLine s = case words s of
69 bs:"#DBCS":_ -> Just (readHex' bs, toEnum 0xDC00)
70 bs:"#UNDEFINED":_ -> Just (readHex' bs, toEnum 0)
71 bs:cs:('#':_):_ -> Just (readHex' bs, readCharHex cs)
74 readHex' :: Enum a => String -> a
75 readHex' ('0':'x':s) = case readHex s of
76 [(n,"")] -> toEnum n -- explicitly call toEnum to catch overflow errors.
77 _ -> error $ "Can't read hex: " ++ show s
78 readHex' s = error $ "Can't read hex: " ++ show s
80 readCharHex :: String -> Char
81 readCharHex s = if c > fromEnum (maxBound :: Word16)
82 then error "Can't handle non-BMP character."
87 -------------------------------------------
88 -- Writing out the main data values.
90 makeTableFile :: String -> [FilePath] -> [(Int,Map.Map Word8 Char)] -> [String]
91 makeTableFile moduleName files maps = concat
92 [ languageDirectives, firstComment files, header,
93 theImports, theTypes, blockSizeText, tablePart]
95 header = [ "module " ++ moduleName ++ " where"
98 tablePart = [ "codePageMap :: [(Word32, CodePageArrays)]"
100 ] ++ (intersperse "\n ," $ map mkTableEntry maps)
102 mkTableEntry (i,m) = " (" ++ show i ++ ", " ++ makeSBE m ++ " )"
103 blockSizeText = ["blockBitSize :: Int", "blockBitSize = " ++ show blockBitSize]
106 makeSBE :: Map.Map Word8 Char -> String
109 , " decoderArray = " ++ mkConvArray es
110 , " , encoderArray = " ++ mkCompactArray (swapMap m)
114 es = [Map.findWithDefault '\0' x m | x <- [minBound..maxBound]]
116 swapMap :: (Ord a, Ord b, Enum a, Enum b) => Map.Map a b -> Map.Map b a
117 swapMap = Map.insert (toEnum 0) (toEnum 0) . Map.fromList . map swap . Map.toList
122 mkConvArray :: Embed a => [a] -> String
123 mkConvArray xs = "ConvArray \"" ++ concatMap mkHex xs ++ "\"#"
126 -------------------------------------------
129 -- The decoding map (from Word8 to Char) can be implemented with a simple array
130 -- of 256 Word16's. Bytes which do not belong to the code page are mapped to
133 -- However, a naive table mapping Char to Word8 would require 2^16 Word8's. We
134 -- can use much less space with the right data structure, since at most 256 of
135 -- those entries are nonzero.
137 -- We use "compact arrays", as described in "Unicode Demystified" by Richard
140 -- Fix a block size S which is a power of two. We compress an array of N
141 -- entries (where N>>S) as follows. First, split the array into blocks of size
142 -- S, then remove all repeate blocks to form the "value" array. Then construct
143 -- a separate "index" array which maps the position of blocks in the old array
144 -- to a position in the value array.
146 -- For example, assume that S=32 we have six blocks ABABCA, each with 32
149 -- Then the compressed table consists of two arrays:
150 -- 1) An array "values", concatenating the unique blocks ABC
151 -- 2) An array "indices" which equals [0,1,0,1,2,0].
153 -- To look up '\100', first calculate divMod 100 32 = (3,4). Since
154 -- indices[3]=1, we look at the second unique block B; thus the encoded byte is
157 -- The upshot of this representation is that the lookup is very quick as it only
158 -- requires two array accesses plus some bit masking/shifting.
160 -- From testing, this is an optimal size.
164 mkCompactArray :: (Embed a, Embed b) => Map.Map a b -> String
165 mkCompactArray m = unlines [
168 , " encoderIndices = " ++ mkConvArray is'
169 , " , encoderValues = "
170 ++ mkConvArray (concat $ Map.elems vs)
171 , " , encoderMax = " ++ show (fst $ Map.findMax m)
175 blockSize = 2 ^ blockBitSize
176 (is,(vs,_)) = compress blockSize $ m
177 is' = map (* blockSize) is
179 type CompressState b = (Map.Map Int [b], Map.Map [b] Int)
180 -- each entry in the list corresponds to a block of size n.
181 compress :: (Bounded a, Enum a, Ord a, Bounded b, Ord b) => Int -> Map.Map a b
182 -> ([Int], CompressState b)
183 compress n ms = runState (mapM lookupOrAdd chunks) (Map.empty, Map.empty)
185 chunks = mkChunks $ map (\i -> Map.findWithDefault minBound i ms)
186 $ [minBound..fst (Map.findMax ms)]
188 mkChunks xs = take n xs : mkChunks (drop n xs)
191 case Map.lookup xs rm of
194 let i = if Map.null m
196 else 1 + fst (Map.findMax m)
197 put (Map.insert i xs m, Map.insert xs i rm)
200 -------------------------------------------
201 -- Static parts of the generated module.
203 languageDirectives :: [String]
204 languageDirectives = ["{-# LANGUAGE MagicHash #-}"]
207 firstComment :: [FilePath] -> [String]
208 firstComment files = map ("-- " ++) $
209 [ "Do not edit this file directly!"
210 , "It was generated by the MakeTable.hs script using the following files:"
211 ] ++ map takeFileName files
213 theImports :: [String]
214 theImports = map ("import " ++ )
215 ["GHC.Prim", "GHC.Base", "GHC.Word"]
218 theTypes = [ "data ConvArray a = ConvArray Addr#"
219 , "data CompactArray a b = CompactArray {"
220 , " encoderMax :: !a,"
221 , " encoderIndices :: !(ConvArray Int),"
222 , " encoderValues :: !(ConvArray b)"
225 , "data CodePageArrays = SingleByteCP {"
226 , " decoderArray :: !(ConvArray Char),"
227 , " encoderArray :: !(CompactArray Char Word8)"
232 -------------------------------------------
233 -- Embed class and associated functions
235 class (Ord a, Enum a, Bounded a, Show a) => Embed a where
238 instance Embed Word8 where
241 instance Embed Word16 where
244 instance Embed Char where
247 -- this is used for the indices of the compressed array.
248 instance Embed Int where
251 showHex' :: Integral a => a -> String
252 showHex' s = "\\x" ++ showHex s ""
254 repDualByte :: Enum c => c -> String
256 | n >= 2^(16::Int) = error "value is too high!"
257 -- NOTE : this assumes little-endian architecture. But we're only using this on Windows,
258 -- so it's probably OK.
259 | otherwise = showHex' (n `mod` 256) ++ showHex' (n `div` 256)