Skip to content

Commit

Permalink
Add a hex-based encoder inspired by cbor.me
Browse files Browse the repository at this point in the history 
This allows you to decompose arbitrary Encoding values into visual hex
dumps.

Closes issue #58.

Signed-off-by: Austin Seipp <austin@well-typed.com>
  • Loading branch information
Alex Mason authored and Austin Seipp committed May 21, 2016
1 parent 6e40a6f commit c1cafbe
Show file tree
Hide file tree
Showing 3 changed files with 253 additions and 2 deletions.
250 changes: 250 additions & 0 deletions Data/Binary/Serialise/CBOR/Pretty.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,250 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UnboxedTuples #-}

-- |
-- Module : Data.Binary.Serialise.CBOR.Pretty
-- Copyright : (c) Duncan Coutts 2015
-- License : BSD3-style (see LICENSE.txt)
--
-- Maintainer : duncan@community.haskell.org
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
-- Pretty printing tools for debugging and analysis.
--
module Data.Binary.Serialise.CBOR.Pretty
( prettyHexEnc -- :: Encoding -> String
) where

#include "cbor.h"

import Data.Word

import qualified Data.ByteString as S
import qualified Data.Text as T

import Data.Binary.Serialise.CBOR.Encoding
import Data.Binary.Serialise.CBOR.Write

import Control.Monad (replicateM_)
import Numeric
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif

--------------------------------------------------------------------------------

newtype PP a = PP (Tokens -> Int -> ShowS -> Either String (Tokens,Int,ShowS,a))

-- | Pretty prints an Encoding in an annotated, hexadecimal format
-- that maps CBOR values to their types. The output format is similar
-- to the format used on http://cbor.me/.
prettyHexEnc :: Encoding -> String
prettyHexEnc e = case runPP pprint e of
Left s -> s
Right (TkEnd,_,ss,_) -> ss ""
Right (toks,_,ss,_) -> ss $ "\nprettyEnc: Not all input was consumed (this is probably a problem with the pretty printing code). Tokens left: " ++ show toks

runPP :: PP a -> Encoding -> Either String (Tokens, Int, ShowS, a)
runPP (PP f) (Encoding enc) = f (enc TkEnd) 0 id

deriving instance Functor PP

instance Applicative PP where
pure a = PP (\toks ind ss -> Right (toks, ind, ss, a))
(PP f) <*> (PP x) = PP $ \toks ind ss -> case f toks ind ss of
Left s -> Left s
Right (toks', ind',ss',f') -> case x toks' ind' ss' of
Left s -> Left s
Right (toks'', ind'', ss'', x') -> Right (toks'', ind'', ss'', f' x')

instance Monad PP where
(PP f) >>= g = PP $ \toks ind ss -> case f toks ind ss of
Left s -> Left s
Right (toks', ind', ss', x) -> let PP g' = g x
in g' toks' ind' ss'
return = pure
fail s = PP $ \_ _ _ -> Left s


indent :: PP ()
indent = PP (\toks ind ss -> Right (toks,ind,ss . (replicate ind ' ' ++),()))

nl :: PP ()
nl = PP (\toks ind ss -> Right (toks,ind,ss . ('\n':), ()))

inc :: Int -> PP ()
inc i = PP (\toks ind ss -> Right (toks,ind+i,ss,()))

dec :: Int -> PP ()
dec i = inc (-i)

getTerm :: PP Tokens
getTerm = PP $ \toks ind ss ->
case unconsToken toks of
Just (tk,rest) -> Right (rest,ind,ss,tk)
Nothing -> Left "getTok: Unexpected end of input"

peekTerm :: PP Tokens
peekTerm = PP $ \toks ind ss ->
case unconsToken toks of
Just (tk,_) -> Right (toks,ind,ss,tk)
Nothing -> Left "peekTerm: Unexpected end of input"

appShowS :: ShowS -> PP ()
appShowS s = PP $ \toks ind ss -> Right (toks,ind,ss . s,())

str :: String -> PP ()
str = appShowS . showString

shown :: Show a => a -> PP ()
shown = appShowS . shows

parens :: PP a -> PP a
parens pp = str "(" *> pp <* str ")"

indef :: PP ()
indef = do
tk <- peekTerm
case tk of
TkBreak TkEnd -> dec 3 >> pprint
_ -> pprint >> indef


pprint :: PP ()
pprint = do
nl
term <- getTerm
hexRep term
str " \t"
case term of
TkInt i TkEnd -> ppTkInt i
TkInteger i TkEnd -> ppTkInteger i
TkBytes bs TkEnd -> ppTkBytes bs
TkBytesBegin TkEnd -> ppTkBytesBegin
TkString t TkEnd -> ppTkString t
TkStringBegin TkEnd -> ppTkStringBegin
TkListLen w TkEnd -> ppTkListLen w
TkListBegin TkEnd -> ppTkListBegin
TkMapLen w TkEnd -> ppTkMapLen w
TkMapBegin TkEnd -> ppTkMapBegin
TkBreak TkEnd -> ppTkBreak
TkTag w TkEnd -> ppTkTag w
TkBool b TkEnd -> ppTkBool b
TkNull TkEnd -> ppTkNull
TkSimple w TkEnd -> ppTkSimple w
TkFloat16 f TkEnd -> ppTkFloat16 f
TkFloat32 f TkEnd -> ppTkFloat32 f
TkFloat64 f TkEnd -> ppTkFloat64 f
TkEnd -> str "# End of input"
_ -> fail $ unwords ["pprint: Unexpected token:", show term]

ppTkInt :: Int -> PP ()
ppTkInt i = str "# int" >> parens (shown i)

ppTkInteger :: Integer -> PP ()
ppTkInteger i = str "# integer" >> parens (shown i)

ppTkBytes :: S.ByteString -> PP ()
ppTkBytes bs = str "# bytes" >> parens (shown (S.length bs))

ppTkBytesBegin :: PP ()
ppTkBytesBegin = str "# bytes(*)" >> inc 3 >> indef

ppTkString :: T.Text -> PP ()
ppTkString t = str "# text" >> parens (shown t)

ppTkStringBegin:: PP ()
ppTkStringBegin = str "# text(*)" >> inc 3 >> indef

ppTkListLen :: Word -> PP ()
ppTkListLen n = do
str "# list"
parens (shown n)
inc 3
replicateM_ (fromIntegral n) pprint
dec 3

ppTkListBegin :: PP ()
ppTkListBegin = str "# list(*)" >> inc 3 >> indef

ppTkMapLen :: Word -> PP ()
ppTkMapLen w = do
str "# map"
parens (shown w)
inc 3
replicateM_ (fromIntegral w) (pprint >> pprint)
dec 3

ppTkMapBegin :: PP ()
ppTkMapBegin = str "# map(*)" >> inc 3

ppTkBreak :: PP ()
ppTkBreak = str "# break"

ppTkTag :: Word -> PP ()
ppTkTag w = do
str "# tag"
parens (shown w)
inc 3
pprint
dec 3

ppTkBool :: Bool -> PP ()
ppTkBool True = str "# bool" >> parens (str "true")
ppTkBool False = str "# bool" >> parens (str "false")

ppTkNull :: PP ()
ppTkNull = str "# null"

ppTkSimple :: Word8 -> PP ()
ppTkSimple w = str "# simple" >> parens (shown w)

ppTkFloat16 :: Float -> PP ()
ppTkFloat16 f = str "# float16" >> parens (shown f)

ppTkFloat32 :: Float -> PP ()
ppTkFloat32 f = str "# float32" >> parens (shown f)

ppTkFloat64 :: Double -> PP ()
ppTkFloat64 f = str "# float64" >> parens (shown f)

unconsToken :: Tokens -> Maybe (Tokens, Tokens)
unconsToken TkEnd = Nothing
unconsToken (TkWord w tks) = Just (TkWord w TkEnd,tks)
unconsToken (TkWord64 w tks) = Just (TkWord64 w TkEnd,tks)
unconsToken (TkInt i tks) = Just (TkInt i TkEnd,tks)
unconsToken (TkInt64 i tks) = Just (TkInt64 i TkEnd,tks)
unconsToken (TkBytes bs tks) = Just (TkBytes bs TkEnd,tks)
unconsToken (TkBytesBegin tks) = Just (TkBytesBegin TkEnd,tks)
unconsToken (TkString t tks) = Just (TkString t TkEnd,tks)
unconsToken (TkStringBegin tks) = Just (TkStringBegin TkEnd,tks)
unconsToken (TkListLen len tks) = Just (TkListLen len TkEnd,tks)
unconsToken (TkListBegin tks) = Just (TkListBegin TkEnd,tks)
unconsToken (TkMapLen len tks) = Just (TkMapLen len TkEnd,tks)
unconsToken (TkMapBegin tks) = Just (TkMapBegin TkEnd,tks)
unconsToken (TkTag w tks) = Just (TkTag w TkEnd,tks)
unconsToken (TkTag64 w64 tks) = Just (TkTag64 w64 TkEnd,tks)
unconsToken (TkInteger i tks) = Just (TkInteger i TkEnd,tks)
unconsToken (TkNull tks) = Just (TkNull TkEnd,tks)
unconsToken (TkUndef tks) = Just (TkUndef TkEnd,tks)
unconsToken (TkBool b tks) = Just (TkBool b TkEnd,tks)
unconsToken (TkSimple w8 tks) = Just (TkSimple w8 TkEnd,tks)
unconsToken (TkFloat16 f16 tks) = Just (TkFloat16 f16 TkEnd,tks)
unconsToken (TkFloat32 f32 tks) = Just (TkFloat32 f32 TkEnd,tks)
unconsToken (TkFloat64 f64 tks) = Just (TkFloat64 f64 TkEnd,tks)
unconsToken (TkBreak tks) = Just (TkBreak TkEnd,tks)

hexRep :: Tokens -> PP ()
hexRep tk = go . toStrictByteString . Encoding $ const tk where
go bs | S.length bs > 16 = case S.splitAt 16 bs of
(h,t) -> indent >> appShowS (hexBS h) >> nl >> go t
| otherwise = indent >> appShowS (hexBS bs)

hexBS :: S.ByteString -> ShowS
hexBS = foldr (.) id . map (\n -> ((if n < 16 then ('0':) else id) . showHex n . (' ':))) . S.unpack
4 changes: 2 additions & 2 deletions Data/Binary/Serialise/CBOR/Write.hs
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
Expand Down
1 change: 1 addition & 0 deletions binary-serialise-cbor.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,6 +69,7 @@ library
Data.Binary.Serialise.CBOR.Encoding
Data.Binary.Serialise.CBOR.FlatTerm
Data.Binary.Serialise.CBOR.IO
Data.Binary.Serialise.CBOR.Pretty
Data.Binary.Serialise.CBOR.Properties
Data.Binary.Serialise.CBOR.Read
Data.Binary.Serialise.CBOR.Write
Expand Down

0 comments on commit c1cafbe

Please sign in to comment.