module Text.PrettyPrint.JoinPrint.HexDump
(
hex
, hex2
, hex4
, hex8
, oxhex
, oxhex2
, oxhex4
, oxhex8
, hexdump
, hexdumpA
) where
import Text.PrettyPrint.JoinPrint.Core
import Data.Array.IO
import Data.Char
import Data.List ( unfoldr )
import Data.Word
import Numeric
import Prelude hiding ( length )
import qualified Prelude as Pre
asterix :: String -> Doc
asterix = text . map (const '*')
hex :: Integral a => a -> Doc
hex i | i >= 0 = text $ showHex i []
| otherwise = asterix $ showHex (abs i) []
hex2 :: Word8 -> Doc
hex2 = padl 2 '0' . text . ($ []) . showHex
hex4 :: Word16 -> Doc
hex4 = padl 4 '0' . text . ($ []) . showHex
hex8 :: Word32 -> Doc
hex8 = padl 8 '0' . text . ($ []) . showHex
oxhex :: Integral a => Int -> a -> Doc
oxhex plen i
| i >= 0 = text "0x" <> padl plen '0' (text $ showHex i [])
| otherwise = text "0x" <> padl plen '*' (asterix $ showHex (abs i) [])
oxhex2 :: Word8 -> Doc
oxhex2 = (text "0x" <>) . hex2
oxhex4 :: Word16 -> Doc
oxhex4 = (text "0x" <>) . hex4
oxhex8 :: Word32 -> Doc
oxhex8 = (text "0x" <>) . hex8
hexdumpA :: Int -> Int -> IOUArray Int Word8 -> IO VDoc
hexdumpA start end arr = getBounds arr >>= next
where
next (s,e) = lineSpans c1_width (segment16Ixs (max s start) (min e end)) arr
c1_width = 2 + sizeHexStr end
lineSpans :: Int -> [(Int,Int)] -> IOUArray Int Word8 -> IO VDoc
lineSpans _ [] _ = return $ vcat []
lineSpans c1_width (x:xs) arr = do
w8s <- spanArr x arr
let vdoc = vcat [firstLine (lineStart $ fst x) w8s]
docTail xs vdoc
where
docTail [] vdoc = return vdoc
docTail (ix@(s,_):ixs) vdoc = do { w8s <- spanArr ix arr
; let d = tailLine (lineStart s) w8s
; docTail ixs (vdoc `vsnoc` d) }
firstLine = hexLine True c1_width
tailLine = hexLine False c1_width
hexdump :: Int -> Int -> [Word8] -> VDoc
hexdump start end bs = hexdump2 start end segs where
segs = segment16 (16 (start `mod` 16)) bs
hexdump2 :: Int -> Int -> [[Word8]] -> VDoc
hexdump2 start end segs =
vcat $ aZipWith (hexLine True c1_width, hexLine False c1_width)
index_nums
segs
where
c1_width = 2 + sizeHexStr end
index_nums = lineNumbers start end
sizeHexStr :: Int -> Int
sizeHexStr n = Pre.length $ showHex (abs n) []
aZipWith :: (a -> b -> c, a -> b -> c) -> [a] -> [b] -> [c]
aZipWith (f,g) (x:xs) (y:ys) = f x y : zipWith g xs ys
aZipWith _ _ _ = []
type Width = Int
type LineNum = Int
hexLine :: Bool -> Width -> LineNum -> [Word8] -> Doc
hexLine is_initial c1_max n xs = c1 <+> empty <+> c2 <+> c3
where
c1 = padl c1_max ' ' (hex n)
c2 = columnPad is_initial (16*3) $ hsep $ map hex2 xs
c3 = columnPad is_initial 16 $ text $ map printable xs
columnPad :: Bool -> Width -> Doc -> Doc
columnPad pad_left w d = step $ length d where
step l | l < w = if pad_left then padl w ' ' d else padr w ' ' d
step _ = d
lineNumbers :: Int -> Int -> [Int]
lineNumbers s e = unfoldr phi $ lineStart s where
phi n | n > e = Nothing
| otherwise = Just (n,n+16)
lineEnd :: Int -> Int
lineEnd l = (l `div` 16) * 16 + 15
lineStart :: Int -> Int
lineStart l = (l `div` 16) * 16
segment16Ixs :: Int -> Int -> [(Int,Int)]
segment16Ixs start end = unfoldr phi start where
phi i | i > end = Nothing
| otherwise = let e1 = lineEnd i in Just ((i, min end e1), e1+1)
segment16 :: Int -> [a] -> [[a]]
segment16 initial ls = let (top,rest) = splitAt initial ls
in top : unfoldr phi rest
where
phi [] = Nothing
phi cs = let (xs,rest) = splitAt 16 cs in Just (xs,rest)
spanArr :: (Int,Int) -> IOUArray Int Word8 -> IO [Word8]
spanArr (l,u) arr = rstep u [] where
rstep i acc | i < l = return acc
rstep i acc = do { e <- readArray arr i ; rstep (i1) (e:acc ) }
printable :: Word8 -> Char
printable = fn . chr . fromIntegral where
fn c | ord c >= 160 = '.'
| isPrint c = c
| otherwise = '.'