codepages/MakeTable.hs

   1 {--
   2 This is a script to generate the necessary tables to support Windows code page
   3 encoding/decoding.
   4
   5 License: see libraries/base/LICENSE
   6
   7 The code page tables are available from :
   8 http://www.unicode.org/Public/MAPPINGS/
   9
  10 To run this script, use e.g.
  11 runghc MakeTable.hs <module-name> <output-file> <codepage-dir>/*.TXT
  12
  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.
  17
  18 --}
  19
  20 module Main where
  21
  22 import System.FilePath
  23 import qualified Data.Map as Map
  24 import System.IO
  25 import Data.Maybe (mapMaybe)
  26 import Data.List (intersperse)
  27 import Data.Word
  28 import Numeric
  29 import Control.Monad.State
  30 import System.Environment
  31 import Control.Exception(evaluate)
  32
  33 main :: IO ()
  34 main = do
  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
  39                    -- skip them.
  40                    ["CPs/CP932.TXT",
  41                     "CPs/CP936.TXT",
  42                     "CPs/CP949.TXT",
  43                     "CPs/CP950.TXT"]
  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
  49   where
  50     readMapAndIx f = do
  51         putStrLn ("Reading " ++ f)
  52         m <- readMap f
  53         return (codePageNum f, m)
  54
  55 -- filenames are assumed to be of the form "CP1250.TXT"
  56 codePageNum :: FilePath -> Int
  57 codePageNum = read . drop 2 . takeBaseName
  58
  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
  64     return ms
  65
  66 parseLine :: Enum a => String -> Maybe (a,Char)
  67 parseLine s = case words s of
  68     ('#':_):_           -> Nothing
  69     bs:"#DBCS":_        -> Just (readHex' bs, toEnum 0xDC00)
  70     bs:"#UNDEFINED":_   -> Just (readHex' bs, toEnum 0)
  71     bs:cs:('#':_):_     -> Just (readHex' bs, readCharHex cs)
  72     _                   -> Nothing
  73
  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
  79
  80 readCharHex :: String -> Char
  81 readCharHex s = if c > fromEnum (maxBound :: Word16)
  82                     then error "Can't handle non-BMP character."
  83                     else toEnum c
  84     where c = readHex' s
  85
  86
  87 -------------------------------------------
  88 -- Writing out the main data values.
  89
  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]
  94   where
  95     header = [ "module " ++ moduleName ++ " where"
  96              , ""
  97              ]
  98     tablePart = [ "codePageMap :: [(Word32, CodePageArrays)]"
  99                 , "codePageMap = ["
 100                 ] ++ (intersperse "\n    ," $ map mkTableEntry maps)
 101                 ++ ["    ]"]
 102     mkTableEntry (i,m) = "    (" ++ show i ++ ", " ++ makeSBE m ++ "    )"
 103     blockSizeText = ["blockBitSize :: Int", "blockBitSize = " ++ show blockBitSize]
 104
 105
 106 makeSBE :: Map.Map Word8 Char -> String
 107 makeSBE m = unlines
 108                 [ "SingleByteCP {"
 109                 , "     decoderArray = " ++ mkConvArray es
 110                 , "     , encoderArray = " ++ mkCompactArray (swapMap m)
 111                 , "   }"
 112                 ]
 113   where
 114     es = [Map.findWithDefault '\0' x m | x <- [minBound..maxBound]]
 115
 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
 118   where
 119     swap (x,y) = (y,x)
 120
 121
 122 mkConvArray :: Embed a => [a] -> String
 123 mkConvArray xs = "ConvArray \"" ++ concatMap mkHex xs ++ "\"#"
 124
 125
 126 -------------------------------------------
 127 -- Compact arrays
 128 --
 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
 131 -- '\0'.
 132 --
 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.
 136 --
 137 -- We use "compact arrays", as described in "Unicode Demystified" by Richard
 138 -- Gillam.
 139 --
 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.
 145 --
 146 -- For example, assume that S=32 we have six blocks ABABCA, each with 32
 147 -- elements.
 148 --
 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].
 152 --
 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
 155 -- B[4].
 156 --
 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.
 159
 160 -- From testing, this is an optimal size.
 161 blockBitSize :: Int
 162 blockBitSize = 6
 163
 164 mkCompactArray :: (Embed a, Embed b) => Map.Map a b -> String
 165 mkCompactArray m = unlines [
 166             ""
 167             , " CompactArray {"
 168             , "        encoderIndices = " ++ mkConvArray is'
 169             , "        , encoderValues = "
 170                     ++ mkConvArray (concat $ Map.elems vs)
 171             , "        , encoderMax = " ++ show (fst $ Map.findMax m)
 172             , "        }"
 173             ]
 174   where
 175     blockSize = 2 ^ blockBitSize
 176     (is,(vs,_)) = compress blockSize $ m
 177     is' = map (* blockSize) is
 178
 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)
 184     where
 185         chunks = mkChunks $ map (\i -> Map.findWithDefault minBound i ms)
 186                     $ [minBound..fst (Map.findMax ms)]
 187         mkChunks [] = []
 188         mkChunks xs = take n xs : mkChunks (drop n xs)
 189         lookupOrAdd xs = do
 190             (m,rm) <- get
 191             case Map.lookup xs rm of
 192                 Just i -> return i
 193                 Nothing -> do
 194                     let i = if Map.null m
 195                                 then 0
 196                                 else 1 + fst (Map.findMax m)
 197                     put (Map.insert i xs m, Map.insert xs i rm)
 198                     return i
 199
 200 -------------------------------------------
 201 -- Static parts of the generated module.
 202
 203 languageDirectives :: [String]
 204 languageDirectives = ["{-# LANGUAGE MagicHash #-}"]
 205
 206
 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
 212
 213 theImports :: [String]
 214 theImports = map ("import " ++ )
 215     ["GHC.Prim", "GHC.Base", "GHC.Word"]
 216
 217 theTypes :: [String]
 218 theTypes = [ "data ConvArray a = ConvArray Addr#"
 219            , "data CompactArray a b = CompactArray {"
 220            , "    encoderMax :: !a,"
 221            , "    encoderIndices :: !(ConvArray Int),"
 222            , "    encoderValues :: !(ConvArray b)"
 223            , "  }"
 224            , ""
 225            , "data CodePageArrays = SingleByteCP {"
 226            , "    decoderArray :: !(ConvArray Char),"
 227            , "    encoderArray :: !(CompactArray Char Word8)"
 228            , "  }"
 229            , ""
 230            ]
 231
 232 -------------------------------------------
 233 -- Embed class and associated functions
 234
 235 class (Ord a, Enum a, Bounded a, Show a) => Embed a where
 236     mkHex :: a -> String
 237
 238 instance Embed Word8 where
 239     mkHex = showHex'
 240
 241 instance Embed Word16 where
 242     mkHex = repDualByte
 243
 244 instance Embed Char where
 245     mkHex = repDualByte
 246
 247 -- this is used for the indices of the compressed array.
 248 instance Embed Int where
 249     mkHex = repDualByte
 250
 251 showHex' :: Integral a => a -> String
 252 showHex' s = "\\x" ++ showHex s ""
 253
 254 repDualByte :: Enum c => c -> String
 255 repDualByte c
 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)
 260   where
 261     n = fromEnum c
 262
 263