utf8-light 0.2 → 0.3
raw patch · 4 files changed
+687/−354 lines, 4 filesdep ~basedep ~bytestring
Dependency ranges changed: base, bytestring
Files
- src/Codec/Binary/UTF8/Light.hs +682/−0
- src/Encoding/UTF8/Light.hs +0/−349
- utf8-light.cabal +4/−4
- utils/utf8flip.hs +1/−1
+ src/Codec/Binary/UTF8/Light.hs view
@@ -0,0 +1,682 @@+{-# OPTIONS_GHC -O2 -fglasgow-exts -fvia-C -optc-O2 #-}+{-# LANGUAGE CPP #-}++{- |+ Module : Codec.Binary.UTF8.Light+ Copyright : (c) Matt Morrow 2008+ License : BSD3++ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : provisional+ Portability : portable++ Lightweight UTF8 handling.+-}++module Codec.Binary.UTF8.Light (+ UTF8(..)+ , c2w+ , w2c+ , i2w+ , w2i+ , lenUTF8+ , lenUTF16+ , countUTF8+ , decodeUTF8+ , encodeUTF8+ , encodeUTF8'+ , withUTF8+ , putUTF8+ , putUTF8Ln+ , hPutUTF8+ , hPutUTF8Ln+ , readUTF8File+ , writeUTF8File+ , appendUTF8File+ , hGetUTF8Line+ , hGetUTF8Contents+ , hGetUTF8+ , hGetUTF8NonBlocking+ , flipUTF8+ , unflipUTF8+ , flipTab+ , unflipTab+ , showHex+ , toBits+ , fromBits+ , Int8,Int16,Int32+ , Word,Word8,Word16,Word32+) where++import Data.Bits+import Data.List(foldl')+import Data.Char(chr,ord)+import Data.Monoid(Monoid(..))+import Data.ByteString(ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import Data.ByteString.Unsafe+import System.IO(Handle)++#if defined(__GLASGOW_HASKELL__)+import GHC.Exts+ (Int(I#),Word(W#),Char(C#)+ ,Ptr(Ptr),FunPtr(FunPtr))+import GHC.Int+ (Int8(I8#),Int16(I16#),Int32(I32#))+import GHC.Word+ (Word8(W8#),Word16(W16#),Word32(W32#))+import GHC.Prim+ (Char#,Int#,Word#,Addr#+ ,ord#,chr#,int2Word#,word2Int#+ ,and#,or#,xor#,not#+ ,gtWord#,geWord#,eqWord#+ ,neWord#,ltWord#,leWord#+ ,uncheckedShiftL#,uncheckedShiftRL#+ ,narrow8Int#,narrow16Int#,narrow32Int#+ ,narrow8Word#,narrow16Word#,narrow32Word#)+#else+import Data.Word+ (Word,Word8,Word16,Word32)+import Data.Int(Int32)+#endif++-- | For convenience+fi :: (Num b, Integral a) => a -> b+fi = fromIntegral++-- | Instances:+-- @ByteString@, @String@+-- , @[Word32]@, @[Word]@+-- , @[Int32]@, @[Int]@+class UTF8 a where+ encode :: a -> ByteString+ decode :: ByteString -> a++instance UTF8 ByteString where+ encode = id+ decode = id++instance UTF8 [Word32] where+ encode = encodeUTF8+ decode = decodeUTF8++instance UTF8 [Word] where+ encode = encodeUTF8 . fmap fi+ decode = fmap fi . decodeUTF8++instance UTF8 [Int32] where+ encode = encodeUTF8 . fmap fi+ decode = fmap fi . decodeUTF8++instance UTF8 [Int] where+ encode = encodeUTF8 . fmap fi+ decode = fmap fi . decodeUTF8++instance UTF8 String where+ encode = encode . fmap ord+ decode = fmap chr . decode++withUTF8 :: (UTF8 a) => a -> (ByteString -> b) -> b+withUTF8 a k = k (encode a)++putUTF8 :: (UTF8 a) => a -> IO ()+putUTF8 = flip withUTF8 B.putStr++putUTF8Ln :: (UTF8 a) => a -> IO ()+putUTF8Ln = flip withUTF8 B.putStrLn++hPutUTF8 :: (UTF8 a) => Handle -> a -> IO ()+hPutUTF8 h = flip withUTF8 (B.hPut h)++hPutUTF8Ln :: (UTF8 a) => Handle -> a -> IO ()+hPutUTF8Ln h = flip withUTF8 (B.hPutStrLn h)++readUTF8File :: (UTF8 a) => FilePath -> IO a+readUTF8File = (return . decode =<<) . B.readFile++writeUTF8File :: (UTF8 a) => FilePath -> a -> IO ()+writeUTF8File p = B.writeFile p . encode++appendUTF8File :: (UTF8 a) => FilePath -> a -> IO ()+appendUTF8File p = B.appendFile p . encode++hGetUTF8Line :: (UTF8 a) => Handle -> IO a+hGetUTF8Line = (return . decode =<<) . B.hGetLine++hGetUTF8Contents :: (UTF8 a) => Handle -> IO a+hGetUTF8Contents = (return . decode =<<) . B.hGetContents++-- | Be careful that you're sure you're not+-- chopping a UTF8 char in two!+hGetUTF8 :: (UTF8 a) => Handle -> Int -> IO a+hGetUTF8 h = (return . decode =<<) . B.hGet h++-- | Same warning as for @hGetUTF8@+hGetUTF8NonBlocking :: (UTF8 a) => Handle -> Int -> IO a+hGetUTF8NonBlocking h = (return . decode =<<) . B.hGetNonBlocking h++-- | Length in Word8s+lenUTF8 :: Word8 -> Int+{-# INLINE lenUTF8 #-}+lenUTF8 w8+ | w8 < 0x80 = 1+ | w8 < 0xe0 = 2+ | w8 < 0xf0 = 3+ | w8 < 0xf8 = 4+ | otherwise = 0++-- | Length in Word16s+lenUTF16 :: Word16 -> Int+lenUTF16 w16+-- I'm sure this could be+-- made more efficient+ | w16`shiftR`10==0x36 = 2+ | w16`shiftR`10==0x37 = 0+ | otherwise = 1++-- | Lengths in Word8s+countUTF8 :: ByteString -> [Int]+countUTF8 s = go 0 (B.length s) s+ where go :: Int -> Int -> ByteString -> [Int]+ go i len s | len <= i = []+ | otherwise = case lenUTF8 (unsafeIndex s i)+ of 0 -> []+ n -> n : go (i+n) len s++encodeUTF8 :: [Word32] -> ByteString+encodeUTF8 = B.pack . concat . encodeUTF8'++#if !defined(__GLASGOW_HASKELL__)++-- | Word32s not representing+-- valid UTF8 chars are /dropped/.+encodeUTF8' :: [Word32] -> [[Word8]]+encodeUTF8' [] = []+encodeUTF8' (x:xs)+ | x < 0x80 =+ [fi x] : encodeUTF8' xs+ | x < 0x800 =+ [ fi(x`shiftR`6.|.0xc0)+ , fi(x.&.0x3f.|.0x80)+ ] : encodeUTF8' xs+ | x < 0xf0000 =+ [ fi(x`shiftR`12.|.0xe0)+ , fi(x`shiftR`6.&.0x3f.|.0x80)+ , fi(x.&.0x3f.|.0x80)+ ] : encodeUTF8' xs+ | x < 0xe00000 =+ [ fi(x`shiftR`18.|.0xf0)+ , fi(x`shiftR`12.&.0x3f.|.0x80)+ , fi(x`shiftR`6.&.0x3f.|.0x80)+ , fi(x.&.0x3f.|.0x80)+ ] : encodeUTF8' xs+ | otherwise = [] : encodeUTF8' xs++decodeUTF8 :: ByteString -> [Word32]+decodeUTF8 s = go 0 (B.length s) s+ where go :: Int -> Int -> ByteString -> [Word32]+ go i len s | len <= i = []+ | otherwise = let c1 = unsafeIndex s i+ in case lenUTF8 c1 of+ 0 -> []+ 1 -> fi c1 : go (i+1) len s+ 2 -> if len <= i+1 then [] else+ let c2 = unsafeIndex s (i+1)+ in fi(c1.&.0x1f)`shiftL`6+ `xor`fi(c2.&.0x3f)+ : go (i+2) len s+ 3 -> if len <= i+2 then [] else+ let c2 = unsafeIndex s (i+1)+ c3 = unsafeIndex s (i+2)+ in fi(c1.&.0x1f)`shiftL`12+ `xor`fi(c2.&.0x3f)`shiftL`6+ `xor`fi(c3.&.0x3f)+ : go (i+3) len s+ 4 -> if len <= i+3 then [] else+ let c2 = unsafeIndex s (i+1)+ c3 = unsafeIndex s (i+2)+ c4 = unsafeIndex s (i+3)+ in fi(c1.&.0x1f)`shiftL`18+ `xor`fi(c2.&.0x3f)`shiftL`12+ `xor`fi(c3.&.0x3f)`shiftL`6+ `xor`fi(c4.&.0x3f)+ : go (i+4) len s++#else++-- | Word32s not representing+-- valid UTF8 chars are /dropped/.+encodeUTF8' :: [Word32] -> [[Word8]]+encodeUTF8' [] = []+-- with ghc-6.10, we+-- can use Word# literalls+-- ==> 0xff00ff00##+encodeUTF8' ((W32# w):xs)+ | w`ltWord#`(int2Word# 0x80#) =+ [W8# w] : encodeUTF8' xs+ | w`ltWord#`(int2Word# 0x800#) =+ [ W8#(w`uncheckedShiftRL#`6#+ `or#`(int2Word# 0xc0#))+ , W8#(w`and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ ] : encodeUTF8' xs+ | w`ltWord#`(int2Word# 0xf0000#) =+ [ W8#(w`uncheckedShiftRL#`12#+ `or#`(int2Word# 0xe0#))+ , W8#(w`uncheckedShiftRL#`6#+ `and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ , W8#(w`and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ ] : encodeUTF8' xs+ | w`ltWord#`(int2Word# 0xe00000#) =+ [ W8#(w`uncheckedShiftRL#`18#+ `or#`(int2Word# 0xf0#))+ , W8#(w`uncheckedShiftRL#`12#+ `and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ , W8#(w`uncheckedShiftRL#`6#+ `and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ , W8#(w`and#`(int2Word# 0x3f#)+ `or#`(int2Word# 0x80#))+ ] : encodeUTF8' xs+ | otherwise = [] : encodeUTF8' xs++-- TODO: ghc-ify decodeUTF8+decodeUTF8 :: ByteString -> [Word32]+decodeUTF8 s = go 0 (B.length s) s+ where go :: Int -> Int -> ByteString -> [Word32]+ go i len s | len <= i = []+ | otherwise = let c1 = unsafeIndex s i+ in case lenUTF8 c1 of+ 0 -> []+ 1 -> fi c1 : go (i+1) len s+ 2 -> if len <= i+1 then [] else+ let c2 = unsafeIndex s (i+1)+ in fi(c1.&.0x1f)`shiftL`6+ `xor`fi(c2.&.0x3f)+ : go (i+2) len s+ 3 -> if len <= i+2 then [] else+ let c2 = unsafeIndex s (i+1)+ c3 = unsafeIndex s (i+2)+ in fi(c1.&.0x1f)`shiftL`12+ `xor`fi(c2.&.0x3f)`shiftL`6+ `xor`fi(c3.&.0x3f)+ : go (i+3) len s+ 4 -> if len <= i+3 then [] else+ let c2 = unsafeIndex s (i+1)+ c3 = unsafeIndex s (i+2)+ c4 = unsafeIndex s (i+3)+ in fi(c1.&.0x1f)`shiftL`18+ `xor`fi(c2.&.0x3f)`shiftL`12+ `xor`fi(c3.&.0x3f)`shiftL`6+ `xor`fi(c4.&.0x3f)+ : go (i+4) len s++#endif++-----------------------------------------------------------------------------++w2c :: Word32 -> Char+{-# INLINE w2c #-}+#if defined(__GLASGOW_HASKELL__)+w2c (W32# w) = C#(chr#(word2Int# w))+#else+w2c = unsafeChr . fromIntegral+#endif++c2w :: Char -> Word32+{-# INLINE c2w #-}+#if defined(__GLASGOW_HASKELL__)+c2w (C# c) = W32#(int2Word#(ord# c))+#else+c2w = fromIntegral . ord+#endif++i2w :: Int -> Word32+{-# INLINE i2w #-}+#if defined(__GLASGOW_HASKELL__)+i2w (I# i) = W32#(int2Word# i)+#else+i2w = fi+#endif++w2i :: Word32 -> Int+{-# INLINE w2i #-}+#if defined(__GLASGOW_HASKELL__)+w2i (W32# w) = I#(word2Int# w)+#else+w2i = fi+#endif++-----------------------------------------------------------------------------++-- misc debug stuff++toBits :: Word8 -> [Word8]+toBits w8 = fmap ((.&.0x01) . (w8`shiftR`)) [7,6,5,4,3,2,1,0]++fromBits :: [Word8] -> Word8+fromBits = foldl' (\a (n,b) -> a.|.b`shiftL`n) 0+ . reverse . zip [0..7] . reverse++hexTab :: ByteString+hexTab = B.pack . fmap B.c2w $+ "0123456789abcdef"++showHex :: Int -> String+showHex i = ("0x"++)+ . flip fmap [28,24,20,16,12,8,4,0] $ \n ->+ B.w2c (unsafeIndex hexTab (i`shiftR`n.&.0xf))++-----------------------------------------------------------------------------++-- now, for fun...++{- |+> ghci> putUTF8Ln $ flipUTF8 "[?np_bs!]"+> [¡sq‾bu¿]+-}+flipUTF8 :: (UTF8 a) => a -> a+flipUTF8 = decode . flipString flipTab . encode++{- |+> ghci> putUTF8Ln $ (unflipUTF8 . flipUTF8) "[?np_bs!]"+> [?np_bs!]+-}+unflipUTF8 :: (UTF8 a) => a -> a+unflipUTF8 = decode . flipString unflipTab . encode++-- | Omits chars it doesn't know how to flip. Possibly+-- it's more desirable to just be id on such chars?+flipString :: [(Int,Int)] -> ByteString -> ByteString+flipString tab = encode+ . reverse+ . fmap (maybe ' ' chr+ . flip lookup tab)+ . decode++unflipTab :: [(Int,Int)]+unflipTab = fmap (uncurry(flip(,))) flipTab++flipTab :: [(Int,Int)]+flipTab = fmap (\(a,b)->(ord a,b))+ [('a', 0x250)+ ,('b', ord 'q')+ ,('c', 0x254)+ ,('d', ord 'p')+ ,('e', 0x1dd)+ ,('f', 0x25f)+ ,('g', 0x183)+ ,('h', 0x265)+ ,('i', 0x131)+ ,('j', 0x27e)+ ,('k', 0x29e)+ ,('l', ord 'l')+ ,('m', 0x26f)+ ,('n', ord 'u')+ ,('o', ord 'o')+ ,('p', ord 'b')+ ,('q', ord 'd')+ ,('r', 0x279)+ ,('s', ord 's')+ ,('t', 0x287)+ ,('u', ord 'n')+ ,('v', 0x28c)+ ,('w', 0x28d)+ ,('x', ord 'x')+ ,('y', 0x28e)+ ,('z', ord 'z')+ ,('.', 0x2d9)+ ,('[', ord ']')+ ,(']', ord '[')+ ,('{', ord '}')+ ,('}', ord '{')+ ,('<', ord '>')+ ,('>', ord '<')+ ,('?', 0xbf)+ ,('!', 0xa1)+ ,('\'', ord ',')+ ,('_', 0x203e)+ ,(';', 0x061b)+ ]++{-+ghci> mapM_ print . zip (fmap show [0..9] ++ fmap (:[]) ['a'..'f']) . fmap (drop 4 . toBits) $ [0..15]+("0",[0,0,0,0])+("1",[0,0,0,1])+("2",[0,0,1,0])+("3",[0,0,1,1])+("4",[0,1,0,0])+("5",[0,1,0,1])+("6",[0,1,1,0])+("7",[0,1,1,1])+("8",[1,0,0,0])+("9",[1,0,0,1])+("a",[1,0,1,0])+("b",[1,0,1,1])+("c",[1,1,0,0])+("d",[1,1,0,1])+("e",[1,1,1,0])+("f",[1,1,1,1])++class (Num a) => Bits a where+ (.&.) :: a -> a -> a+ (.|.) :: a -> a -> a+ xor :: a -> a -> a+ complement :: a -> a+ shift :: a -> Int -> a+ rotate :: a -> Int -> a+ bit :: Int -> a+ setBit :: a -> Int -> a+ clearBit :: a -> Int -> a+ complementBit :: a -> Int -> a+ testBit :: a -> Int -> Bool+ bitSize :: a -> Int+ isSigned :: a -> Bool+ shiftL :: a -> Int -> a+ shiftR :: a -> Int -> a+ rotateL :: a -> Int -> a+ rotateR :: a -> Int -> a++uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRL# :: Int# -> Int# -> Int#+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftRL# :: Word# -> Int# -> Word#+-}++++{-+data Char#+gtChar# :: Char# -> Char# -> Bool+geChar# :: Char# -> Char# -> Bool+eqChar# :: Char# -> Char# -> Bool+neChar# :: Char# -> Char# -> Bool+ltChar# :: Char# -> Char# -> Bool+leChar# :: Char# -> Char# -> Bool+ord# :: Char# -> Int#++data Int#+(+#) :: Int# -> Int# -> Int#+(-#) :: Int# -> Int# -> Int#+(*#) :: Int# -> Int# -> Int#+(>#) :: Int# -> Int# -> Bool+(>=#) :: Int# -> Int# -> Bool+(==#) :: Int# -> Int# -> Bool+(/=#) :: Int# -> Int# -> Bool+(<#) :: Int# -> Int# -> Bool+(<=#) :: Int# -> Int# -> Bool+chr# :: Int# -> Char#+int2Word# :: Int# -> Word#+uncheckedIShiftL# :: Int# -> Int# -> Int#+uncheckedIShiftRA# :: Int# -> Int# -> Int#+uncheckedIShiftRL# :: Int# -> Int# -> Int#++data Word#+plusWord# :: Word# -> Word# -> Word#+minusWord# :: Word# -> Word# -> Word#+timesWord# :: Word# -> Word# -> Word#+and# :: Word# -> Word# -> Word#+or# :: Word# -> Word# -> Word#+xor# :: Word# -> Word# -> Word#+not# :: Word# -> Word#+uncheckedShiftL# :: Word# -> Int# -> Word#+uncheckedShiftRL# :: Word# -> Int# -> Word#+word2Int# :: Word# -> Int#+gtWord# :: Word# -> Word# -> Bool+geWord# :: Word# -> Word# -> Bool+eqWord# :: Word# -> Word# -> Bool+neWord# :: Word# -> Word# -> Bool+ltWord# :: Word# -> Word# -> Bool+leWord# :: Word# -> Word# -> Bool+narrow8Int# :: Int# -> Int#+narrow16Int# :: Int# -> Int#+narrow32Int# :: Int# -> Int#+narrow8Word# :: Word# -> Word#+narrow16Word# :: Word# -> Word#+narrow32Word# :: Word# -> Word#++data MutByteArr# s+newByteArray# :: Int# -> State# s -> (#State# s, MutByteArr# s#)+newPinnedByteArray# :: Int# -> State# s -> (#State# s, MutByteArr# s#)+byteArrayContents# :: ByteArr# -> Addr#+sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool+unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (#State# s, ByteArr##)+sizeofByteArray# :: ByteArr# -> Int#+sizeofMutableByteArray# :: MutByteArr# s -> Int#+indexCharArray# :: ByteArr# -> Int# -> Char#+indexWideCharArray# :: ByteArr# -> Int# -> Char#+indexIntArray# :: ByteArr# -> Int# -> Int#+indexWordArray# :: ByteArr# -> Int# -> Word#+indexAddrArray# :: ByteArr# -> Int# -> Addr#+indexInt8Array# :: ByteArr# -> Int# -> Int#+indexInt16Array# :: ByteArr# -> Int# -> Int#+indexInt32Array# :: ByteArr# -> Int# -> Int#+indexInt64Array# :: ByteArr# -> Int# -> Int#+indexWord8Array# :: ByteArr# -> Int# -> Word#+indexWord16Array# :: ByteArr# -> Int# -> Word#+indexWord32Array# :: ByteArr# -> Int# -> Word#+indexWord64Array# :: ByteArr# -> Int# -> Word#+readCharArray# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Char##)+readWideCharArray# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Char##)+readIntArray# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Int##)+readWordArray# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Word##)+readAddrArray# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Addr##)+readInt8Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Int##)+readInt16Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Int##)+readInt32Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Int##)+readInt64Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Int##)+readWord8Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Word##)+readWord16Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Word##)+readWord32Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Word##)+readWord64Array# :: MutByteArr# s -> Int# -> State# s -> (#State# s, Word##)+writeCharArray# :: MutByteArr# s -> Int# -> Char# -> State# s -> State# s+writeWideCharArray# :: MutByteArr# s -> Int# -> Char# -> State# s -> State# s+writeIntArray# :: MutByteArr# s -> Int# -> Int# -> State# s -> State# s+writeWordArray# :: MutByteArr# s -> Int# -> Word# -> State# s -> State# s+writeAddrArray# :: MutByteArr# s -> Int# -> Addr# -> State# s -> State# s+writeInt8Array# :: MutByteArr# s -> Int# -> Int# -> State# s -> State# s+writeInt16Array# :: MutByteArr# s -> Int# -> Int# -> State# s -> State# s+writeInt32Array# :: MutByteArr# s -> Int# -> Int# -> State# s -> State# s+writeInt64Array# :: MutByteArr# s -> Int# -> Int# -> State# s -> State# s+writeWord8Array# :: MutByteArr# s -> Int# -> Word# -> State# s -> State# s+writeWord16Array# :: MutByteArr# s -> Int# -> Word# -> State# s -> State# s+writeWord32Array# :: MutByteArr# s -> Int# -> Word# -> State# s -> State# s+writeWord64Array# :: MutByteArr# s -> Int# -> Word# -> State# s -> State# s++data Addr#+nullAddr# :: Addr#+plusAddr# :: Addr# -> Int# -> Addr#+minusAddr# :: Addr# -> Addr# -> Int#+remAddr# :: Addr# -> Int# -> Int#+addr2Int# :: Addr# -> Int#+int2Addr# :: Int# -> Addr#+gtAddr# :: Addr# -> Addr# -> Bool+geAddr# :: Addr# -> Addr# -> Bool+eqAddr# :: Addr# -> Addr# -> Bool+neAddr# :: Addr# -> Addr# -> Bool+ltAddr# :: Addr# -> Addr# -> Bool+leAddr# :: Addr# -> Addr# -> Bool+indexCharOffAddr# :: Addr# -> Int# -> Char#+indexWideCharOffAddr# :: Addr# -> Int# -> Char#+indexIntOffAddr# :: Addr# -> Int# -> Int#+indexWordOffAddr# :: Addr# -> Int# -> Word#+indexAddrOffAddr# :: Addr# -> Int# -> Addr#+indexInt8OffAddr# :: Addr# -> Int# -> Int#+indexInt16OffAddr# :: Addr# -> Int# -> Int#+indexInt32OffAddr# :: Addr# -> Int# -> Int#+indexInt64OffAddr# :: Addr# -> Int# -> Int#+indexWord8OffAddr# :: Addr# -> Int# -> Word#+indexWord16OffAddr# :: Addr# -> Int# -> Word#+indexWord32OffAddr# :: Addr# -> Int# -> Word#+indexWord64OffAddr# :: Addr# -> Int# -> Word#+readCharOffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Char##)+readWideCharOffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Char##)+readIntOffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Int##)+readWordOffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Word##)+readAddrOffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Addr##)+readInt8OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Int##)+readInt16OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Int##)+readInt32OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Int##)+readInt64OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Int##)+readWord8OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Word##)+readWord16OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Word##)+readWord32OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Word##)+readWord64OffAddr# :: Addr# -> Int# -> State# s -> (#State# s, Word##)+writeCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeWideCharOffAddr# :: Addr# -> Int# -> Char# -> State# s -> State# s+writeIntOffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWordOffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeAddrOffAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s+writeInt8OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt16OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt32OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeInt64OffAddr# :: Addr# -> Int# -> Int# -> State# s -> State# s+writeWord8OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord16OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord32OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s+writeWord64OffAddr# :: Addr# -> Int# -> Word# -> State# s -> State# s++data State# s+data RealWorld++dataToTag# :: a -> Int#+tagToEnum# :: Int# -> a++reallyUnsafePtrEquality# :: a -> a -> Int#++data BCO#+addrToHValue# :: Addr# -> (#a#)+mkApUpd0# :: BCO# -> (#a#)+newBCO# :: ByteArr# -> ByteArr# -> Array# a -> Int# -> ByteArr# -> State# s -> (#State# s, BCO##)+unpackClosure# :: a -> (#Addr#, Array# b, ByteArr##)+getApStackVal# :: a -> Int# -> (#Int#, b#)+seq :: a -> b -> b+inline :: a -> a+lazy :: a -> a++data Any a+unsafeCoerce# :: a -> b++++--------GHC.Exts++data Int = I# Int#+data Word = W# Word#++data Char = C# Char#+data Ptr a = Ptr Addr#+data FunPtr a = FunPtr Addr#++shiftL# :: Word# -> Int# -> Word#+shiftRL# :: Word# -> Int# -> Word#+iShiftL# :: Int# -> Int# -> Int#+iShiftRA# :: Int# -> Int# -> Int#+iShiftRL# :: Int# -> Int# -> Int#+-}+
− src/Encoding/UTF8/Light.hs
@@ -1,349 +0,0 @@-{-# OPTIONS_GHC -O2 -fglasgow-exts #-}--{- |- Module : Encoding.UTF8.Light- Copyright : (c) Matt Morrow 2008- License : BSD3-- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : provisional- Portability : portable--}--module Encoding.UTF8.Light (- UTF8(..)- , lenUTF8- , lenUTF16- , countUTF8- , decodeUTF8- , encodeUTF8- , encodeUTF8'- , withUTF8- , putUTF8- , putUTF8Ln- , hPutUTF8- , hPutUTF8Ln- , readUTF8File- , writeUTF8File- , appendUTF8File- , hGetUTF8Line- , hGetUTF8Contents- , hGetUTF8- , hGetUTF8NonBlocking- , flipUTF8- , unflipUTF8- , flipTab- , unflipTab- , showHex- , toBits- , fromBits-) where--import Data.Bits-import Data.Word(Word8,Word16,Word32)-import Data.List(foldl')-import Data.Monoid(Monoid(..))-import Data.ByteString(ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Internal(c2w,w2c)-import Data.ByteString.Unsafe-import Data.Char(chr,ord)-import System.IO(Handle)---- | For convenience-fi :: (Num b, Integral a) => a -> b-fi = fromIntegral---- | Instances: @ByteString@, @String@, @[Int]@-class UTF8 a where- encode :: a -> ByteString- decode :: ByteString -> a--instance UTF8 ByteString where- encode = id- decode = id--instance UTF8 [Int] where- encode = encodeUTF8- decode = decodeUTF8--instance UTF8 String where- encode = encode . fmap ord- decode = fmap chr . decode--withUTF8 :: (UTF8 a) => a -> (ByteString -> b) -> b-withUTF8 a k = k (encode a)--putUTF8 :: (UTF8 a) => a -> IO ()-putUTF8 = flip withUTF8 B.putStr--putUTF8Ln :: (UTF8 a) => a -> IO ()-putUTF8Ln = flip withUTF8 B.putStrLn--hPutUTF8 :: (UTF8 a) => Handle -> a -> IO ()-hPutUTF8 h = flip withUTF8 (B.hPut h)--hPutUTF8Ln :: (UTF8 a) => Handle -> a -> IO ()-hPutUTF8Ln h = flip withUTF8 (B.hPutStrLn h)--readUTF8File :: (UTF8 a) => FilePath -> IO a-readUTF8File = (return . decode =<<) . B.readFile--writeUTF8File :: (UTF8 a) => FilePath -> a -> IO ()-writeUTF8File p = B.writeFile p . encode--appendUTF8File :: (UTF8 a) => FilePath -> a -> IO ()-appendUTF8File p = B.appendFile p . encode--hGetUTF8Line :: (UTF8 a) => Handle -> IO a-hGetUTF8Line = (return . decode =<<) . B.hGetLine--hGetUTF8Contents :: (UTF8 a) => Handle -> IO a-hGetUTF8Contents = (return . decode =<<) . B.hGetContents---- | Be careful that you're sure you're not--- chopping a UTF8 char in two!-hGetUTF8 :: (UTF8 a) => Handle -> Int -> IO a-hGetUTF8 h = (return . decode =<<) . B.hGet h---- | Same warning as for @hGetUTF8@-hGetUTF8NonBlocking :: (UTF8 a) => Handle -> Int -> IO a-hGetUTF8NonBlocking h = (return . decode =<<) . B.hGetNonBlocking h---- | Length in Word8s--- XXX: use (<) instead of shiftR and (==)-lenUTF8 :: Word8 -> Int-lenUTF8 w8- | w8`shiftR`7==0x00 = 1- | w8`shiftR`5==0x06 = 2- | w8`shiftR`4==0x0e = 3- | w8`shiftR`3==0x1e = 4- | otherwise = 0---- | Length in Word16s-lenUTF16 :: Word16 -> Int-lenUTF16 w16- | w16`shiftR`10==0x36 = 2- | w16`shiftR`10==0x37 = 0- | otherwise = 1---- | Lengths in Word8s-countUTF8 :: ByteString -> [Int]-countUTF8 s = go 0 (B.length s) s- where go :: Int -> Int -> ByteString -> [Int]- go i len s- | len <= i = []- | otherwise = let n = lenUTF8 (unsafeIndex s i)- i' = i+n- in if n==0- then []- else i' `seq` n : go i' len s--encodeUTF8 :: [Int] -> ByteString-encodeUTF8 = B.pack . concat . encodeUTF8'--encodeUTF8' :: [Int] -> [[Word8]]-encodeUTF8' [] = []-encodeUTF8' (x:xs)- | x.&.0xffffff80==0 =- [fi x] : encodeUTF8' xs- | x.&.0xfffff800==0 =- [ fi(x`shiftR`6.|.0xc0)- , fi(x.&.0x3f.|.0x80)- ] : encodeUTF8' xs- | x.&.0xffff0000==0 =- [ fi(x`shiftR`12.|.0xe0)- , fi(x`shiftR`6.&.0x3f.|.0x80)- , fi(x.&.0x3f.|.0x80)- ] : encodeUTF8' xs- | x.&.0xffe00000==0 =- [ fi(x`shiftR`18.|.0xf0)- , fi(x`shiftR`12.&.0x3f.|.0x80)- , fi(x`shiftR`6.&.0x3f.|.0x80)- , fi(x.&.0x3f.|.0x80)- ] : encodeUTF8' xs- | otherwise = [] : encodeUTF8' xs--decodeUTF8 :: ByteString -> [Int]-decodeUTF8 s = go 0 (B.length s) s- where go :: Int -> Int -> ByteString -> [Int]- go i len s- | len <= i = []- | otherwise =- let c1 = unsafeIndex s i- in case lenUTF8 c1 of- 0 -> []- 1 -> let i' = i+1- in i'`seq`- fi c1 : go i' len s- 2 -> if len <= i+1- then []- else- let c2 = unsafeIndex s (i+1)- i' = i+2- in i'`seq`- fi(c1.&.0x1f)`shiftL`6- `xor`fi(c2.&.0x3f)- : go i' len s- 3 -> if len <= i+2- then []- else- let c2 = unsafeIndex s (i+1)- c3 = unsafeIndex s (i+2)- i' = i+3- in i'`seq`- fi(c1.&.0x1f)`shiftL`12- `xor`fi(c2.&.0x3f)`shiftL`6- `xor`fi(c3.&.0x3f)- : go i' len s- 4 -> if len <= i+3- then []- else- let c2 = unsafeIndex s (i+1)- c3 = unsafeIndex s (i+2)- c4 = unsafeIndex s (i+3)- i' = i+4- in i'`seq`- fi(c1.&.0x1f)`shiftL`18- `xor`fi(c2.&.0x3f)`shiftL`12- `xor`fi(c3.&.0x3f)`shiftL`6- `xor`fi(c4.&.0x3f)- : go i' len s----------------------------------------------------------------------------------- misc debug stuff--toBits :: Word8 -> [Word8]-toBits w8 = fmap ((.&.0x01) . (w8`shiftR`)) [7,6,5,4,3,2,1,0]--fromBits :: [Word8] -> Word8-fromBits = foldl' (\a (n,b) -> a.|.b`shiftL`n) 0- . reverse . zip [0..7] . reverse--hexTab :: ByteString-hexTab = B.pack . fmap c2w $- "0123456789abcdef"--showHex :: Int -> String-showHex i = ("0x"++)- . flip fmap [28,24,20,16,12,8,4,0] $ \n ->- w2c (unsafeIndex hexTab (i`shiftR`n.&.0xf))----------------------------------------------------------------------------------- now, for fun...--{- |-> ghci> putUTF8Ln $ flipUTF8 "[?np_bs!]"-> [¡sq‾bu¿]--}-flipUTF8 :: (UTF8 a) => a -> a-flipUTF8 = decode . flipString flipTab . encode--{- |-> ghci> putUTF8Ln $ (unflipUTF8 . flipUTF8) "[?np_bs!]"-> [?np_bs!]--}-unflipUTF8 :: (UTF8 a) => a -> a-unflipUTF8 = decode . flipString unflipTab . encode---- | Omits chars it doesn't know how to flip. Possibly--- it's more desirable to just be id on such chars?-flipString :: [(Int,Int)] -> ByteString -> ByteString-flipString tab = encode- . reverse- . fmap (maybe ' ' chr- . flip lookup tab)- . decode--unflipTab :: [(Int,Int)]-unflipTab = fmap (uncurry(flip(,))) flipTab--flipTab :: [(Int,Int)]-flipTab = fmap (\(a,b)->(ord a,b))- [('a', 0x250)- ,('b', ord 'q')- ,('c', 0x254)- ,('d', ord 'p')- ,('e', 0x1dd)- ,('f', 0x25f)- ,('g', 0x183)- ,('h', 0x265)- ,('i', 0x131)- ,('j', 0x27e)- ,('k', 0x29e)- ,('l', ord 'l')- ,('m', 0x26f)- ,('n', ord 'u')- ,('o', ord 'o')- ,('p', ord 'b')- ,('q', ord 'd')- ,('r', 0x279)- ,('s', ord 's')- ,('t', 0x287)- ,('u', ord 'n')- ,('v', 0x28c)- ,('w', 0x28d)- ,('x', ord 'x')- ,('y', 0x28e)- ,('z', ord 'z')- ,('.', 0x2d9)- ,('[', ord ']')- ,(']', ord '[')- ,('{', ord '}')- ,('}', ord '{')- ,('<', ord '>')- ,('>', ord '<')- ,('?', 0xbf)- ,('!', 0xa1)- ,('\'', ord ',')- ,('_', 0x203e)- ,(';', 0x061b)- ]--{--ghci> mapM_ print . zip (fmap show [0..9] ++ fmap (:[]) ['a'..'f']) . fmap (drop 4 . toBits) $ [0..15]-("0",[0,0,0,0])-("1",[0,0,0,1])-("2",[0,0,1,0])-("3",[0,0,1,1])-("4",[0,1,0,0])-("5",[0,1,0,1])-("6",[0,1,1,0])-("7",[0,1,1,1])-("8",[1,0,0,0])-("9",[1,0,0,1])-("a",[1,0,1,0])-("b",[1,0,1,1])-("c",[1,1,0,0])-("d",[1,1,0,1])-("e",[1,1,1,0])-("f",[1,1,1,1])--class (Num a) => Bits a where- (.&.) :: a -> a -> a- (.|.) :: a -> a -> a- xor :: a -> a -> a- complement :: a -> a- shift :: a -> Int -> a- rotate :: a -> Int -> a- bit :: Int -> a- setBit :: a -> Int -> a- clearBit :: a -> Int -> a- complementBit :: a -> Int -> a- testBit :: a -> Int -> Bool- bitSize :: a -> Int- isSigned :: a -> Bool- shiftL :: a -> Int -> a- shiftR :: a -> Int -> a- rotateL :: a -> Int -> a- rotateR :: a -> Int -> a--uncheckedIShiftL# :: Int# -> Int# -> Int#-uncheckedIShiftRA# :: Int# -> Int# -> Int#-uncheckedIShiftRL# :: Int# -> Int# -> Int#-uncheckedShiftL# :: Word# -> Int# -> Word#-uncheckedShiftRL# :: Word# -> Int# -> Word#--}-
utf8-light.cabal view
@@ -1,10 +1,10 @@ name: utf8-light-version: 0.2+version: 0.3 cabal-version: >= 1.3 build-type: Simple license: BSD3 license-file: LICENSE-category: Text+category: Codec author: Matt Morrow copyright: Matt Morrow maintainer: Matt Morrow <mjm2002@gmail.com>@@ -16,9 +16,9 @@ library build-depends: base, bytestring ghc-options: -O2 -fglasgow-exts -fvia-C -optc-O2- extensions:+ extensions: CPP hs-source-dirs: src- exposed-modules: Encoding.UTF8.Light+ exposed-modules: Codec.Binary.UTF8.Light executable utf8flip executable: utf8flip
utils/utf8flip.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -O2 #-}-import Encoding.UTF8.Light+import Codec.Binary.UTF8.Light main :: IO () main = putUTF8 . unlines . reverse . fmap flipUTF8