Removed obsolete template code
Ignore-this: d555a44d9f5cf27c03f7b5ddd3a6ef4a darcs-hash:20090813043811-a4fee-6ce046900453472765daf718ffe5446cf65ce4e7
This commit is contained in:
Henning Guenther
parent
dc6c1f142d
commit
414adf4e7d
@ -1,116 +0,0 @@
|
||||
{- This module is used to create a haskell file with static address-arrays in it -}
|
||||
|
||||
module Data.Encoding.Helper.Data where
|
||||
|
||||
import Data.Char (ord)
|
||||
import Data.Word (Word8)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Bits (shiftR)
|
||||
import Data.List (sortBy,genericLength)
|
||||
import Data.Encoding.Helper.XML
|
||||
|
||||
linear :: Word8 -> Word8 -> Word8 -> Word8 -> Int
|
||||
linear w1 w2 w3 w4
|
||||
= (fromIntegral (w4-0x30))
|
||||
+ (fromIntegral (w3-0x81))*10
|
||||
+ (fromIntegral (w2-0x30))*1260
|
||||
+ (fromIntegral (w1-0x81))*12600
|
||||
|
||||
linear2 :: Word8 -> Word8 -> Int
|
||||
linear2 w1 w2 = (fromIntegral (w2 - (if w2<=0x7E
|
||||
then 0x40
|
||||
else 0x41)))
|
||||
+ (fromIntegral (w1-0x81))*190
|
||||
|
||||
createStandardModule :: IO ()
|
||||
createStandardModule = do
|
||||
let fn = "gb-18030-2000.xml"
|
||||
str <- readFile fn
|
||||
writeFile "Data/Encoding/GB18030Data.hs" $ createModuleFromFile fn str standardRanges standardRRanges
|
||||
|
||||
standardRanges =
|
||||
[('\x0000','\x0451')
|
||||
,('\x2010','\x2642')
|
||||
,('\x2E81','\x361A')
|
||||
,('\x3918','\x3CE0')
|
||||
,('\x4056','\x415F')
|
||||
,('\x4337','\x44D6')
|
||||
,('\x464C','\x478D')
|
||||
,('\x4947','\x49B7')
|
||||
,('\x4C77','\x9FA5')
|
||||
,('\xD800','\xE864')
|
||||
,('\xF92C','\xFA29')
|
||||
,('\xFE30','\xFFE5')
|
||||
]
|
||||
|
||||
standardRRanges =
|
||||
[( 0, 819)
|
||||
,( 7922, 9218)
|
||||
,(11329,12972)
|
||||
,(13738,14697)
|
||||
,(15583,15846)
|
||||
,(16318,16728)
|
||||
,(17102,17417)
|
||||
,(17859,17960)
|
||||
,(18664,19042)
|
||||
,(33469,33549)
|
||||
,(37845,38077)
|
||||
,(39108,39393)
|
||||
,(39420,188999)]
|
||||
|
||||
createModuleFromFile :: String -> String -> [(Char,Char)] -> [(Int,Int)] -> String
|
||||
createModuleFromFile name str = createModule (readDecodeTable name str)
|
||||
|
||||
createModule :: [(Char,[Word8])] -> [(Char,Char)] -> [(Int,Int)] -> String
|
||||
createModule mp ranges rranges = unlines $
|
||||
["{-# LANGUAGE CPP,MagicHash #-}"
|
||||
,"module Data.Encoding.GB18030Data where"
|
||||
,""
|
||||
,"import Data.ByteString(ByteString)"
|
||||
,"#if __GLASGOW_HASKELL__>=608"
|
||||
,"import Data.ByteString.Unsafe(unsafePackAddressLen)"
|
||||
,"#else"
|
||||
,"import Data.ByteString.Base(unsafePackAddressLen)"
|
||||
,"#endif"
|
||||
,"import System.IO.Unsafe(unsafePerformIO)"]
|
||||
++ (createAddrVars "arr" (map (uncurry $ createAddr mp) ranges))
|
||||
++ (createAddrVars "rarr" (map (uncurry $ createRAddr4 mp) rranges))
|
||||
++ (createAddrVar "rrarr" (createRAddr2 mp))
|
||||
|
||||
createAddrVars :: String -> [[Word8]] -> [String]
|
||||
createAddrVars base conts = concatMap (\(n,cont) ->
|
||||
createAddrVar (base++show n) cont) (zip [1..] conts)
|
||||
|
||||
createAddrVar :: String -> [Word8] -> [String]
|
||||
createAddrVar name cont =
|
||||
[""
|
||||
,name++" :: ByteString"
|
||||
,name++" = unsafePerformIO $ unsafePackAddressLen "++show (length cont)++" \""++addr cont++"\"#"
|
||||
]
|
||||
|
||||
createAddr :: [(Char,[Word8])] -> Char -> Char -> [Word8]
|
||||
createAddr mp f t = let
|
||||
lst = sortBy (comparing fst) [el | el@(ch,_) <- mp, ch>=f, ch<=t]
|
||||
in concatMap (\(ch,seq) -> let
|
||||
l = length seq
|
||||
in [fromIntegral l]++seq++(replicate (4-l) 0)) lst
|
||||
|
||||
createRAddr2 :: [(Char,[Word8])] -> [Word8]
|
||||
createRAddr2 mp = let
|
||||
lst = sortBy (comparing snd)
|
||||
[ (ch,v) | (ch,[w1,w2]) <- mp,let v = linear2 w1 w2]
|
||||
in concatMap (\(ch,_) -> let i = ord ch
|
||||
in [fromIntegral (i `shiftR` 8)
|
||||
,fromIntegral i]) lst
|
||||
|
||||
createRAddr4 :: [(Char,[Word8])] -> Int -> Int -> [Word8]
|
||||
createRAddr4 mp f t = let
|
||||
lst = sortBy (comparing snd)
|
||||
[ (ch,v) | (ch,[w1,w2,w3,w4]) <- mp,
|
||||
let v = linear w1 w2 w3 w4, v>=f, v<=t ]
|
||||
in concatMap (\(ch,_) -> let i = ord ch
|
||||
in [fromIntegral (i `shiftR` 8)
|
||||
,fromIntegral i]) lst
|
||||
|
||||
addr :: [Word8] -> String
|
||||
addr = concatMap (\w -> "\\"++show w)
|
||||
@ -1,120 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Data.Encoding.Helper.Template where
|
||||
|
||||
import Data.Encoding.Base
|
||||
import Data.Bits
|
||||
import Data.Char
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Map as Map (fromList,lookup)
|
||||
import Data.Array.Unboxed
|
||||
import Data.Typeable
|
||||
import Language.Haskell.TH
|
||||
|
||||
makeISOInstance :: String -> FilePath -> Q [Dec]
|
||||
makeISOInstance name file = do
|
||||
trans <- runIO (readTranslation 0 id file)
|
||||
mp <- encodingMap (validTranslations trans)
|
||||
arr <- decodingArray (fillTranslations 0 255 trans)
|
||||
return $ encodingInstance 'encodeWithMap 'decodeWithArray 'encodeableWithMap name mp arr
|
||||
|
||||
makeJISInstance :: Int -> String -> FilePath -> Q [Dec]
|
||||
makeJISInstance offset name file = do
|
||||
trans <- runIO (readTranslation offset (\src -> (src `shiftR` 8,src .&. 0xFF)) file)
|
||||
mp <- encodingMap2 (validTranslations trans)
|
||||
arr <- decodingArray2 (fillTranslations (0x21,0x21) (0x7E,0x7E) trans)
|
||||
return $ encodingInstance 'encodeWithMap2 'decodeWithArray2 'encodeableWithMap name mp arr
|
||||
|
||||
encodingInstance :: Name -> Name -> Name -> String -> Exp -> Exp -> [Dec]
|
||||
encodingInstance enc dec able name mp arr
|
||||
= [ DataD [] rname [] [NormalC rname []] [''Show,''Eq,''Typeable]
|
||||
, ValD (VarP rmp) (NormalB mp) []
|
||||
, InstanceD [] (AppT (ConT ''Encoding) (ConT rname))
|
||||
[FunD 'encodeChar
|
||||
[Clause [WildP] (NormalB $ AppE (VarE enc) (VarE rmp))
|
||||
[]
|
||||
]
|
||||
,FunD 'decodeChar
|
||||
[Clause [WildP] (NormalB $ AppE (VarE dec) (VarE rarr))
|
||||
[ValD (VarP rarr) (NormalB arr) []]
|
||||
]
|
||||
,FunD 'encodeable
|
||||
[Clause [WildP] (NormalB $ AppE (VarE able) (VarE rmp))
|
||||
[]
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
rname = mkName name
|
||||
rarr = mkName "arr"
|
||||
rmp = mkName ("decoding_map_"++name)
|
||||
|
||||
createCharArray :: [(Integer,Maybe Char)] -> Integer -> Integer -> Q Exp
|
||||
createCharArray lst f t = createArray (map (\(x,y) ->
|
||||
(LitE $ IntegerL x,mbCharToExp y)
|
||||
) lst) (LitE $ IntegerL f) (LitE $ IntegerL t)
|
||||
|
||||
createCharArray2 :: [((Integer,Integer),Maybe Char)] -> (Integer,Integer) -> (Integer,Integer) -> Q Exp
|
||||
createCharArray2 lst (f1,f2) (t1,t2)
|
||||
= createArray (map (\((x1,x2),y) ->
|
||||
(TupE [integerExp x1,integerExp x2],mbCharToExp y)
|
||||
) lst)
|
||||
(TupE [integerExp f1,integerExp f2])
|
||||
(TupE [integerExp t1,integerExp t2])
|
||||
|
||||
integerExp :: Integer -> Exp
|
||||
integerExp i = LitE $ IntegerL i
|
||||
|
||||
mbCharToExp :: Maybe Char -> Exp
|
||||
mbCharToExp Nothing = LitE (IntegerL (-1))
|
||||
mbCharToExp (Just c) = LitE (IntegerL $ fromIntegral $ ord c)
|
||||
|
||||
createArray :: [(Exp,Exp)] -> Exp -> Exp -> Q Exp
|
||||
createArray lst from to
|
||||
= return $ AppE
|
||||
(AppE
|
||||
(VarE 'array)
|
||||
(TupE [from,to]))
|
||||
(ListE [TupE [x,y] | (x,y) <- lst])
|
||||
|
||||
decodingArray :: [(Integer,Maybe Char)] -> Q Exp
|
||||
decodingArray trans = createCharArray trans 0 255
|
||||
|
||||
decodingArray2 :: [((Integer,Integer),Maybe Char)] -> Q Exp
|
||||
decodingArray2 trans = createCharArray2 trans (0x21,0x21) (0x7E,0x7E)
|
||||
|
||||
encodingMap :: [(Integer,Char)] -> Q Exp
|
||||
encodingMap trans = return $ AppE
|
||||
(VarE 'fromList)
|
||||
(ListE [ TupE [LitE $ CharL to,LitE $ IntegerL from]
|
||||
| (from,to) <- trans])
|
||||
|
||||
encodingMap2 :: [((Integer,Integer),Char)] -> Q Exp
|
||||
encodingMap2 trans = return $ AppE
|
||||
(VarE 'fromList)
|
||||
(ListE [ TupE [LitE $ CharL to,TupE [integerExp f1,integerExp f2]]
|
||||
| ((f1,f2),to) <- trans])
|
||||
|
||||
readTranslation :: Int -> (Integer -> a) -> FilePath -> IO [(a,Maybe Char)]
|
||||
readTranslation offset f file = do
|
||||
cont <- readFile file
|
||||
return $ mapMaybe (\ln -> case drop offset ln of
|
||||
[src] -> Just (f src,Nothing)
|
||||
[src,trg] -> Just (f src,Just $ chr $ fromIntegral trg)
|
||||
_ -> Nothing) (parseTranslationTable cont)
|
||||
|
||||
parseTranslationTable :: String -> [[Integer]]
|
||||
parseTranslationTable cont = filter (not.null) (map (\ln -> map read (takeWhile ((/='#').head) (words ln))) (lines cont))
|
||||
|
||||
fillTranslations :: (Ix a,Show a) => a -> a -> [(a,Maybe Char)] -> [(a,Maybe Char)]
|
||||
fillTranslations f t = merge (range (f,t))
|
||||
where
|
||||
merge xs [] = map (\x -> (x,Nothing)) xs
|
||||
merge [] cs = error $ "Data.Encoding.Helper.Template.fillTranslations: Character translations out of range: " ++ show cs
|
||||
merge (x:xs) (y:ys) = if x < fst y
|
||||
then (x,Nothing):(merge xs (y:ys))
|
||||
else y:(merge xs ys)
|
||||
|
||||
validTranslations :: [(a,Maybe Char)] -> [(a,Char)]
|
||||
validTranslations = mapMaybe (\(n,mc) -> case mc of
|
||||
Nothing -> Nothing
|
||||
Just c -> Just (n,c))
|
||||
@ -1,41 +0,0 @@
|
||||
module Data.Encoding.Helper.XML where
|
||||
|
||||
import Data.Char
|
||||
import Data.List (find)
|
||||
import Data.Word
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Text.XML.HaXml.Parse
|
||||
import Text.XML.HaXml.Types
|
||||
import Text.XML.HaXml.Verbatim
|
||||
import Numeric
|
||||
|
||||
readDecodeTable :: String -> String -> [(Char,[Word8])]
|
||||
readDecodeTable name str = let
|
||||
Document _ _ (Elem root_name _ conts) _ = xmlParse name str
|
||||
in concat $ mapMaybe findAssignments conts
|
||||
|
||||
findAssignments :: Content i -> Maybe [(Char,[Word8])]
|
||||
findAssignments (CElem (Elem "assignments" _ conts) _)
|
||||
= Just $ mapMaybe findAssignment conts
|
||||
findAssignments _ = Nothing
|
||||
|
||||
findAssignment :: Content i -> Maybe (Char,[Word8])
|
||||
findAssignment (CElem (Elem "a" attrs _) _) = do
|
||||
u <- lookup "u" attrs
|
||||
b <- lookup "b" attrs
|
||||
return (chr $ readHexInt (showAttValue u),parseBinary b)
|
||||
findAssignment _ = Nothing
|
||||
|
||||
parseBinary :: AttValue -> [Word8]
|
||||
parseBinary val = map (fromIntegral.readHexInt) (words (showAttValue val))
|
||||
|
||||
showAttValue :: AttValue -> String
|
||||
showAttValue (AttValue lst) = concat $ map (\el -> case el of
|
||||
Left str -> str
|
||||
Right ref -> verbatim ref) lst
|
||||
|
||||
readHexInt :: String -> Int
|
||||
readHexInt str = case find (\x -> snd x == "") (readHex str) of
|
||||
Nothing -> error "Not a hex"
|
||||
Just (x,_) -> x
|
||||
|
||||
Loading…
Reference in New Issue
Block a user