uhexdump (empty) → 0.1
raw patch · 7 files changed
+550/−0 lines, 7 filesdep +basedep +utf8-stringsetup-changed
Dependencies added: base, utf8-string
Files
- FileBytes.hs +33/−0
- LICENSE +26/−0
- Makefile +4/−0
- Setup.lhs +3/−0
- UTF8.lhs +340/−0
- uhexdump.cabal +15/−0
- uhexdump.hs +129/−0
+ FileBytes.hs view
@@ -0,0 +1,33 @@+module FileBytes where++import Data.Word (Word8)+import Foreign.Marshal.Array (allocaArray, peekArray, pokeArray)+import System.IO (hFileSize, Handle, hGetBuf, hPutBuf, openBinaryFile, hClose,+ IOMode(ReadMode, WriteMode))++-- ----------------------------------------------------------------------+-- supporting utf-8 stuff+-- ----------------------------------------------------------------------++readFileBytes :: FilePath -> IO [Word8]+readFileBytes f =+ do h <- openBinaryFile f ReadMode+ hsize <- fromIntegral `fmap` hFileSize h+ hGetBytes h hsize++writeFileBytes :: FilePath -> [Word8] -> IO ()+writeFileBytes f ws =+ do h <- openBinaryFile f WriteMode+ hPutBytes h (length ws) ws+ hClose h++hGetBytes :: Handle -> Int -> IO [Word8]+hGetBytes h c = allocaArray c $ \p ->+ do c' <- hGetBuf h p c+ peekArray c' p++hPutBytes :: Handle -> Int -> [Word8] -> IO ()+hPutBytes h c ws = allocaArray c $ \p ->+ do pokeArray p ws+ hPutBuf h p c+
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) Eric Kow 2008.+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. Neither the name of the author nor the names of his contributors+ may 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 AUTHORS 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.
+ Makefile view
@@ -0,0 +1,4 @@+PROGRAMS := hexdump-utf8++$(PROGRAMS): % : %.hs+ ghc --make -Wall $@
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ UTF8.lhs view
@@ -0,0 +1,340 @@+Copyright (c) 2002, members of the Haskell Internationalisation Working+Group All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* 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.+* Neither the name of the Haskell Internationalisation Working Group nor+ the names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT OWNER 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.++This module provides lazy stream encoding/decoding facilities for UTF-8,+the Unicode Transformation Format with 8-bit words.++2002-09-02 Sven Moritz Hallberg <pesco@gmx.de>+++> module UTF8 where++> import Data.Char (ord, chr)+> import Data.Word (Word8, Word16, Word32)+> import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))++++///- UTF-8 in General -///++Adapted from the Unicode standard, version 3.2,+Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):++ Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte+ 000000000xxxxxxx 0xxxxxxx+ 00000yyyyyxxxxxx 110yyyyy 10xxxxxx+ zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx+ 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++Also from the Unicode standard, version 3.2,+Table 3.1B "Legal UTF-8 Byte Sequences":++ Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte+ U+0000..U+007F 00..7F+ U+0080..U+07FF C2..DF 80..BF+ U+0800..U+0FFF E0 A0..BF 80..BF+ U+1000..U+CFFF E1..EC 80..BF 80..BF+ U+D000..U+D7FF ED 80..9F 80..BF+ U+D800..U+DFFF ill-formed+ U+E000..U+FFFF EE..EF 80..BF 80..BF+ U+10000..U+3FFFF F0 90..BF 80..BF 80..BF+ U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF+ U+100000..U+10FFFF F4 80..8F 80..BF 80..BF++++///- Encoding Functions -///++Must the encoder ensure that no illegal byte sequences are output or+can we trust the Haskell system to supply only legal values?+For now I include error case for the surrogate values U+D800..U+DFFF and+out-of-range scalars.++The function is pretty much a transscript of table 3.1B with error checks.+It dispatches the actual encoding to functions specific to the number of+required bytes.++> encodeOne :: Char -> [Word8]+> encodeOne c+>-- The report guarantees in (6.1.2) that this won't happen:+>-- | n < 0 = error "encodeUTF8: ord returned a negative value"+> | n < 0x0080 = encodeOne_onebyte n8+> | n < 0x0800 = encodeOne_twobyte n16+> | n < 0xD800 = encodeOne_threebyte n16+> | n < 0xE000 = error "encodeUTF8: ord returned a surrogate value"+> | n < 0x10000 = encodeOne_threebyte n16+>-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.+> | n < 0x10FFFF = encodeOne_fourbyte n32+> | otherwise = error "encodeUTF8: ord returned a value above 0x10FFFF"+> where+> n = ord c :: Int+> n8 = fromIntegral n :: Word8+> n16 = fromIntegral n :: Word16+> n32 = fromIntegral n :: Word32+++With the above, a stream decoder is trivial:++> encode :: [Char] -> [Word8]+> encode = concatMap encodeOne+++Now follow the individual encoders for certain numbers of bytes...+ _+ / | __ ___ __ __+ / ^| // /__/ // //+ /.==| \\ //_ // //+It's // || // \_/_//_//_ and it's here to stay!++> encodeOne_onebyte :: Word8 -> [Word8]+> encodeOne_onebyte cp = [cp]+++00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx++> encodeOne_twobyte :: Word16 -> [Word8]+> encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]+> where+> xs, ys :: Word8+> ys = fromIntegral (shiftR cp 6)+> xs = (fromIntegral cp) .&. 0x3F+++zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx++> encodeOne_threebyte :: Word16 -> [Word8]+> encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]+> where+> xs, ys, zs :: Word8+> xs = (fromIntegral cp) .&. 0x3F+> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+> zs = fromIntegral (shiftR cp 12)+++000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++> encodeOne_fourbyte :: Word32 -> [Word8]+> encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]+> where+> xs, ys, zs, us :: Word8+> xs = (fromIntegral cp) .&. 0x3F+> ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+> zs = (fromIntegral (shiftR cp 12)) .&. 0x3F+> us = fromIntegral (shiftR cp 18)++++///- Decoding -///++The decoding is a bit more involved. The byte sequence could contain all+sorts of corruptions. The user must be able to either notice or ignore these+errors.++I will first look at the decoding of a single character. The process+consumes a certain number of bytes from the input. It returns the+remaining input and either an error and the index of its occurance in the+byte sequence or the decoded character.++> data Error++The first byte in a sequence starts with either zero, two, three, or four+ones and one zero to indicate the length of the sequence. If it doesn't,+it is invalid. It is dropped and the next byte interpreted as the start+of a new sequence.++> = InvalidFirstByte++All bytes in the sequence except the first match the bit pattern 10xxxxxx.+If one doesn't, it is invalid. The sequence up to that point is dropped+and the "invalid" byte interpreted as the start of a new sequence. The error+includes the length of the partial sequence and the number of expected bytes.++> | InvalidLaterByte Int -- the byte at relative index n was invalid++If a sequence ends prematurely, it has been truncated. It dropped and+decoding stops. The error reports the actual and expected lengths of the+sequence.++> | Truncated Int Int -- only n of m expected bytes were present++Some sequences would represent code points which would be encoded as a+shorter sequence by a conformant encoder. Such non-shortest sequences are+considered erroneous and dropped. The error reports the actual and+expected number of bytes used.++> | NonShortest Int Int -- n instead of m bytes were used++Unicode code points are in the range of [0..0x10FFFF]. Any values outside+of those bounds are simply invalid.++> | ValueOutOfBounds++There is no such thing as "surrogate pairs" any more in UTF-8. The+corresponding code points now form illegal byte sequences.++> | Surrogate+> deriving (Show, Eq)+++Second, third, and fourth bytes share the common requirement to start+with the bit sequence 10. So, here's the function to check that property.++> first_bits_not_10 :: Word8 -> Bool+> first_bits_not_10 b+> | (b.&.0xC0) /= 0x80 = True+> | otherwise = False+++Erm, OK, the single-character decoding function's return type is a bit+longish. It is a tripel:++ - The first component contains the decoded character or an error+ if the byte sequence was erroneous.+ - The second component contains the number of bytes that were consumed+ from the input.+ - The third component contains the remaining bytes of input.++> decodeOne :: [Word8] -> (Either Error Char, Int, [Word8])+> decodeOne bs@(b1:rest)+> | b1 < 0x80 = decodeOne_onebyte bs+> | b1 < 0xC0 = (Left InvalidFirstByte, 1, rest)+> | b1 < 0xE0 = decodeOne_twobyte bs+> | b1 < 0xEE = decodeOne_threebyte bs+> | b1 < 0xF5 = decodeOne_fourbyte bs+> | otherwise = (Left ValueOutOfBounds, 1, rest)+> decodeOne [] = error "UTF8.decodeOne: No input"+++0xxxxxxx -> 000000000xxxxxxx++> decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8])+> decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs)+> decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)"++> cpToChar :: Integral a => a -> Char+> cpToChar = chr . fromIntegral+++110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx++> decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8])+> decodeOne_twobyte (_:[])+> = (Left (Truncated 1 2), 1, [])+> decodeOne_twobyte (b1:b2:bs)+> | b1 < 0xC2 = (Left (NonShortest 2 1), 2, bs)+> | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs))+> | otherwise = (Right (cpToChar result), 2, bs)+> where+> xs, ys, result :: Word32+> xs = fromIntegral (b2.&.0x3F)+> ys = fromIntegral (b1.&.0x1F)+> result = shiftL ys 6 .|. xs+> decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)"+++1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx++> decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8])+> decodeOne_threebyte (_:[]) = threebyte_truncated 1+> decodeOne_threebyte (_:_:[]) = threebyte_truncated 2+> decodeOne_threebyte bs@(b1:b2:b3:rest)+> | first_bits_not_10 b2+> = (Left (InvalidLaterByte 1), 1, drop 1 bs)+> | first_bits_not_10 b3+> = (Left (InvalidLaterByte 2), 2, drop 2 bs)+> | result < 0x0080+> = (Left (NonShortest 3 1), 3, rest)+> | result < 0x0800+> = (Left (NonShortest 3 2), 3, rest)+> | result >= 0xD800 && result < 0xE000+> = (Left Surrogate, 3, rest)+> | otherwise+> = (Right (cpToChar result), 3, rest)+> where+> xs, ys, zs, result :: Word32+> xs = fromIntegral (b3.&.0x3F)+> ys = fromIntegral (b2.&.0x3F)+> zs = fromIntegral (b1.&.0x0F)+> result = shiftL zs 12 .|. shiftL ys 6 .|. xs+> decodeOne_threebyte[]+> = error "UTF8.decodeOne_threebyte: No input (can't happen)"++> threebyte_truncated :: Int -> (Either Error Char, Int, [Word8])+> threebyte_truncated n = (Left (Truncated n 3), n, [])+++11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx++> decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8])+> decodeOne_fourbyte (_:[]) = fourbyte_truncated 1+> decodeOne_fourbyte (_:_:[]) = fourbyte_truncated 2+> decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3+> decodeOne_fourbyte bs@(b1:b2:b3:b4:rest)+> | first_bits_not_10 b2+> = (Left (InvalidLaterByte 1), 1, drop 1 bs)+> | first_bits_not_10 b3+> = (Left (InvalidLaterByte 2), 2, drop 2 bs)+> | first_bits_not_10 b4+> = (Left (InvalidLaterByte 3), 3, drop 3 bs)+> | result < 0x0080+> = (Left (NonShortest 4 1), 4, rest)+> | result < 0x0800+> = (Left (NonShortest 4 2), 4, rest)+> | result < 0x10000+> = (Left (NonShortest 4 3), 4, rest)+> | result > 0x10FFFF+> = (Left ValueOutOfBounds, 4, rest)+> | otherwise+> = (Right (cpToChar result), 4, rest)+> where+> xs, ys, zs, us, result :: Word32+> xs = fromIntegral (b4 .&. 0x3F)+> ys = fromIntegral (b3 .&. 0x3F)+> zs = fromIntegral (b2 .&. 0x3F)+> us = fromIntegral (b1 .&. 0x07)+> result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18+> decodeOne_fourbyte[]+> = error "UTF8.decodeOne_fourbyte: No input (can't happen)"++> fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8])+> fourbyte_truncated n = (Left (Truncated n 4), n, [])+++The decoder examines all input, recording decoded characters as well as+error-index pairs along the way.++> decode :: [Word8] -> ([Char], [(Error,Int)])+> decode bytes = iter 0 [] [] bytes+> where+> iter :: Int -> [Char] -> [(Error,Int)] -> [Word8]+> -> ([Char], [(Error,Int)])+> iter _ cs es [] = (reverse cs, reverse es)+> iter idx cs es bs+> = case decodeOne bs of+> (Left e, n, rest) -> iter (idx+n) cs ((e,idx):es) rest+> (Right c, n, rest) -> iter (idx+n) (c:cs) es rest+
+ uhexdump.cabal view
@@ -0,0 +1,15 @@+name: uhexdump+version: 0.1+synopsis: hex dumper for UTF-8 text+description: hex dumper for UTF-8 text+category: Text+license: BSD3+license-file: LICENSE+author: Eric Kow+maintainer: <E.Y.Kow@brighton.ac.uk>+build-Depends: base, utf8-string+build-type: Simple++executable: uhexdump+main-is: uhexdump.hs+ghc-options: -Wall
+ uhexdump.hs view
@@ -0,0 +1,129 @@+module Main where++-- TODO+-- ----+-- o figure out how to use utf8-string for the decoding with+-- errors [this lets us get rid of our FileBytes and UTF8+-- modules+-- o colourise badly encoded characters (switch to something+-- easier to type than guillmets)+-- o fancy flags++import Control.Monad (forM_)+import Data.Bits+import Data.Char (isPrint)+import Data.List (intersperse, inits)+import Data.Word (Word8)+import System.Environment (getArgs)+import System.IO (stdin, hFileSize, openBinaryFile, hClose, IOMode(ReadMode))+import qualified Numeric as N+import Prelude hiding (putStrLn, putStr)++import System.IO.UTF8+import UTF8 hiding (decode)+import FileBytes++main :: IO ()+main =+ do args <- getArgs+ hs <- case args of+ [] -> return [stdin]+ _ -> mapM (\f -> openBinaryFile f ReadMode) args+ forM_ hs $ \h ->+ do hsize <- fromIntegral `fmap` hFileSize h+ bs <- hGetBytes h hsize+ putStr $ unlines $+ map (dump h_size) $ clump c_size $ decode bs+ hClose h+ where+ h_size = 60+ c_size = 16++dump :: Int -> [HexChar] -> String+dump hex_sz hs =+ hex_part ++ padding ++ char_part -- hex_part ++ char_part+ where+ hex_part = (foldr (.) id $+ intersperse (showChar ' ') $+ map showHex hs) ""+ char_part = concat $ map show hs+ padding = replicate (hex_sz - length hex_part) ' '++clump :: Show a => Int -> [a] -> [[a]]+clump n = clumpBy (length.show) n 1++-- | break a list of items into sublists of length < the clump+-- size, taking into consideration that each item in the clump+-- will have a sep-size padding interspersed+--+-- any item whose length is greater than the clump size+-- is put into a clump by itself+--+-- given a length function+-- @clumpBy (length.show) 8 ["hello", "this", "is", "a", "list"]@+clumpBy :: (a -> Int) -> Int -> Int -> [a] -> [[a]]+clumpBy f l sep items = iter [] items+ where+ iter acc [] = reverse acc+ iter acc cs =+ case break toobig (inits cs) of+ ([[]],_) -> next 1 -- all too big+ (_ ,[]) -> iter (cs:acc) [] -- none too big+ (_,(x:_)) -> next (length x)+ where next n = iter (take n cs : acc) (drop n cs)+ toobig x = (sum . intersperse sep . map f) x > l++-- -------------------------------------------------------------------+--+-- -------------------------------------------------------------------++class ShowHex a where+ showHex :: a -> String -> String++instance ShowHex Int where+ showHex = N.showHex++instance ShowHex Word8 where+ showHex w = showHex big . showHex small+ where+ small, big :: Int+ small = fromIntegral $ w .&. 0x0f+ big = fromIntegral $ shiftR w 4++instance ShowHex HexChar where+ showHex h = foldr (.) id $ map showHex $ getBytes h++-- -------------------------------------------------------------------+--+-- -------------------------------------------------------------------++data HexChar =+ HexChar Char [Word8]+ | HexError (Error,Int) [Word8]++instance Show HexChar where+ show (HexChar '\r' _) = noshow+ show (HexChar '\n' _) = noshow+ show (HexChar '\t' _) = noshow+ show (HexChar c _) | isPrint c = [c]+ show (HexChar _ _) = noshow+ show h@(HexError _ _) = showString "{{" $ (showHex h) "}}"++noshow :: String+noshow = "."++getBytes :: HexChar -> [Word8]+getBytes (HexChar _ ws) = ws+getBytes (HexError _ ws) = ws++decode :: [Word8] -> [HexChar]+decode bytes = iter 0 [] bytes+ where+ iter :: Int -> [HexChar] -> [Word8] -> [HexChar]+ iter _ cs [] = reverse cs+ iter idx cs bs+ = case decodeOne bs of+ (Left e, n, rest) -> let hc = HexError (e,idx) (take n bs)+ in iter (idx+n) (hc:cs) rest+ (Right c, n, rest) -> let hc = HexChar c (take n bs)+ in iter (idx+n) (hc:cs) rest