uhexdump-0.2: uhexdump.hs

module Main where

-- TODO
-- ----
-- o figure out how to use utf8-string for the decoding with
--   errors [this lets us get rid of the UTF8 module]
-- o colourise badly encoded characters (switch to something
--   easier to type than guillmets)
-- o fancy flags

import Control.Monad (forM_)
import Data.Bits
import qualified Data.ByteString as B
import Data.Char (isPrint)
import Data.List (intersperse, inits)
import Data.Word (Word8)
import System.Environment (getArgs)
import System.IO (stdin, openBinaryFile, hClose, IOMode(ReadMode))
import qualified Numeric as N
import Prelude hiding (putStrLn, putStr)

import System.IO.UTF8
import UTF8 hiding (decode)

main :: IO ()
main =
 do args <- getArgs
    hs <- case args of
           [] -> return [stdin]
           _  -> mapM (\f -> openBinaryFile f ReadMode) args
    forM_ hs $ \h ->
     do bs <- B.unpack `fmap` B.hGetContents h
        putStr $ unlines $
          map (dump h_size) $ clump c_size $ decode bs
        hClose h
 where
  h_size = 55
  c_size = 16

dump :: Int -> [HexChar] -> String
dump hex_sz hs =
  hex_part ++ padding ++ 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 (drop 1 $ inits cs) of
        ([],_)    -> next 1           -- first 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