utf8-light (empty) → 0.1
raw patch · 5 files changed
+415/−0 lines, 5 filesdep +basedep +bytestringsetup-changed
Dependencies added: base, bytestring
Files
- LICENSE +26/−0
- Setup.lhs +4/−0
- src/Encoding/UTF8/Light.hs +349/−0
- utf8-light.cabal +30/−0
- utils/utf8flip.hs +6/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) Matt Morrow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the author may not be used to endorse or promote+ products derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ src/Encoding/UTF8/Light.hs view
@@ -0,0 +1,349 @@+{-# 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
@@ -0,0 +1,30 @@+name: utf8-light+version: 0.1+cabal-version: >= 1.3+build-type: Simple+license: BSD3+license-file: LICENSE+category: Text+author: Matt Morrow+copyright: Matt Morrow+maintainer: Matt Morrow <mjm2002@gmail.com>+stability: provisional+synopsis: utf8-light+description: Lightweight UTF8 handling. Haddock docs are at+ <http://code.haskell.org/~morrow/code/haskell/utf8-light/haddock/>.++library+ build-depends: base,bytestring+ ghc-options: -O2 -fglasgow-exts+ extensions:+ hs-source-dirs: src+ exposed-modules: Encoding.UTF8.Light++executable utf8flip+ executable: utf8flip+ main-is: utf8flip.hs+ build-depends: base, bytestring+ hs-source-dirs: utils, src+ ghc-options: -O2 -fglasgow-exts++
+ utils/utf8flip.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -O2 #-}+import Encoding.UTF8.Light+main :: IO ()+main = putUTF8 . unlines+ . reverse . fmap flipUTF8+ . lines =<< getContents