{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE UnboxedTuples       #-}

-- |
-- Module      : Codec.CBOR.Pretty
-- Copyright   : (c) Duncan Coutts 2015-2017
-- 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 Codec.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           Codec.CBOR.ByteArray.Sliced
import           Codec.CBOR.Encoding
import           Codec.CBOR.Write

import qualified Control.Monad.Fail as Fail
import           Control.Monad                       (replicateM_)
import           GHC.Int (Int64)
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/.
--
-- For example, with the term:
--
-- @
-- 'Prelude.putStrLn' . 'prettyHexEnc' . 'Codec.CBOR.encode' $
--   ( True
--   , [1,2,3::Int]
--   , ('Data.Map.fromList' [(\"Hello\",True),(\"World\",False)], "This is a long string which wraps")
--   )
-- @
--
-- You get:
--
-- @
-- 83      # list(3)
--    f5   # bool(true)
--    9f   # list(*)
--       01        # int(1)
--       02        # int(2)
--       03        # int(3)
--    ff   # break
--    82   # list(2)
--       a2        # map(2)
--          65 48 65 6c 6c 6f      # text(\"Hello\")
--          f5     # bool(true)
--          65 57 6f 72 6c 64      # text(\"World\")
--          f4     # bool(false)
--       78 21 54 68 69 73 20 69 73 20 61 20 6c 6f 6e 67
--       20 73 74 72 69 6e 67 20 77 68 69 63 68 20 77 72
--       61 70 73          # text("This is a long string which wraps")
-- @
--
-- @since 0.2.0.0
prettyHexEnc :: Encoding -> String
prettyHexEnc :: Encoding -> String
prettyHexEnc Encoding
e = case forall a. PP a -> Encoding -> Either String (Tokens, Int, ShowS, a)
runPP PP ()
pprint Encoding
e of
  Left String
s -> String
s
  Right (Tokens
TkEnd,Int
_,ShowS
ss,()
_) -> ShowS
ss String
""
  Right (Tokens
toks,Int
_,ShowS
ss,()
_) -> ShowS
ss forall a b. (a -> b) -> a -> b
$ String
"\nprettyEnc: Not all input was consumed (this is probably a problem with the pretty printing code). Tokens left: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Tokens
toks

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

deriving instance Functor PP

instance Applicative PP where
  pure :: forall a. a -> PP a
pure a
a  = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP (\Tokens
toks Int
ind ShowS
ss -> forall a b. b -> Either a b
Right (Tokens
toks, Int
ind, ShowS
ss, a
a))
  (PP Tokens
-> Int -> ShowS -> Either String (Tokens, Int, ShowS, a -> b)
f) <*> :: forall a b. PP (a -> b) -> PP a -> PP b
<*> (PP Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a)
x) = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
toks Int
ind ShowS
ss -> case Tokens
-> Int -> ShowS -> Either String (Tokens, Int, ShowS, a -> b)
f Tokens
toks Int
ind ShowS
ss of
    Left String
s                     -> forall a b. a -> Either a b
Left String
s
    Right (Tokens
toks', Int
ind',ShowS
ss',a -> b
f') -> case Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a)
x Tokens
toks' Int
ind' ShowS
ss' of
      Left String
s                          -> forall a b. a -> Either a b
Left String
s
      Right (Tokens
toks'', Int
ind'', ShowS
ss'', a
x') -> forall a b. b -> Either a b
Right (Tokens
toks'', Int
ind'', ShowS
ss'', a -> b
f' a
x')

instance Monad PP where
  (PP Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a)
f) >>= :: forall a b. PP a -> (a -> PP b) -> PP b
>>= a -> PP b
g = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
toks Int
ind ShowS
ss -> case Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a)
f Tokens
toks Int
ind ShowS
ss of
    Left String
s -> forall a b. a -> Either a b
Left String
s
    Right (Tokens
toks', Int
ind', ShowS
ss', a
x) -> let PP Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, b)
g' = a -> PP b
g a
x
      in Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, b)
g' Tokens
toks' Int
ind' ShowS
ss'
  return :: forall a. a -> PP a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
#if !MIN_VERSION_base(4,13,0)
  fail = Fail.fail
#endif

instance Fail.MonadFail PP where
  fail :: forall a. String -> PP a
fail String
s = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
_ Int
_ ShowS
_ -> forall a b. a -> Either a b
Left String
s

indent :: PP ()
indent :: PP ()
indent = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP (\Tokens
toks Int
ind ShowS
ss -> forall a b. b -> Either a b
Right (Tokens
toks,Int
ind,ShowS
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Int -> a -> [a]
replicate Int
ind Char
' ' forall a. [a] -> [a] -> [a]
++),()))

nl :: PP ()
nl :: PP ()
nl = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP (\Tokens
toks Int
ind ShowS
ss -> forall a b. b -> Either a b
Right (Tokens
toks,Int
ind,ShowS
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'forall a. a -> [a] -> [a]
:), ()))

inc :: Int -> PP ()
inc :: Int -> PP ()
inc Int
i = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP (\Tokens
toks Int
ind ShowS
ss -> forall a b. b -> Either a b
Right (Tokens
toks,Int
indforall a. Num a => a -> a -> a
+Int
i,ShowS
ss,()))

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

getTerm :: PP Tokens
getTerm :: PP Tokens
getTerm = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
toks Int
ind ShowS
ss ->
  case Tokens -> Maybe (Tokens, Tokens)
unconsToken Tokens
toks of
    Just (Tokens
tk,Tokens
rest) -> forall a b. b -> Either a b
Right (Tokens
rest,Int
ind,ShowS
ss,Tokens
tk)
    Maybe (Tokens, Tokens)
Nothing -> forall a b. a -> Either a b
Left String
"getTok: Unexpected end of input"

peekTerm :: PP Tokens
peekTerm :: PP Tokens
peekTerm = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
toks Int
ind ShowS
ss ->
  case Tokens -> Maybe (Tokens, Tokens)
unconsToken Tokens
toks of
    Just (Tokens
tk,Tokens
_) -> forall a b. b -> Either a b
Right (Tokens
toks,Int
ind,ShowS
ss,Tokens
tk)
    Maybe (Tokens, Tokens)
Nothing -> forall a b. a -> Either a b
Left String
"peekTerm: Unexpected end of input"

appShowS :: ShowS -> PP ()
appShowS :: ShowS -> PP ()
appShowS ShowS
s = forall a.
(Tokens -> Int -> ShowS -> Either String (Tokens, Int, ShowS, a))
-> PP a
PP forall a b. (a -> b) -> a -> b
$ \Tokens
toks Int
ind ShowS
ss -> forall a b. b -> Either a b
Right (Tokens
toks,Int
ind,ShowS
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s,())

str :: String -> PP ()
str :: String -> PP ()
str = ShowS -> PP ()
appShowS forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString

shown :: Show a => a -> PP ()
shown :: forall a. Show a => a -> PP ()
shown = ShowS -> PP ()
appShowS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows

parens :: PP a -> PP a
parens :: forall a. PP a -> PP a
parens PP a
pp = String -> PP ()
str String
"(" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PP a
pp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> PP ()
str String
")"

indef :: PP () -> PP ()
indef :: PP () -> PP ()
indef PP ()
pp = do
  Tokens
tk <- PP Tokens
peekTerm
  case Tokens
tk of
    TkBreak Tokens
TkEnd -> Int -> PP ()
dec Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP ()
pprint
    Tokens
_ -> PP ()
pp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP () -> PP ()
indef PP ()
pp


pprint :: PP ()
pprint :: PP ()
pprint = do
  PP ()
nl
  Tokens
term <- PP Tokens
getTerm
  Tokens -> PP ()
hexRep Tokens
term
  String -> PP ()
str String
" "
  case Tokens
term of
    TkInt      Int
i   Tokens
TkEnd     -> Int -> PP ()
ppTkInt Int
i
    TkInt      Int
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkInt64    Int64
i   Tokens
TkEnd     -> Int64 -> PP ()
ppTkInt64 Int64
i
    TkInt64    Int64
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkInteger  Integer
i   Tokens
TkEnd     -> Integer -> PP ()
ppTkInteger Integer
i
    TkInteger  Integer
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkWord64   Word64
w   Tokens
TkEnd     -> Word64 -> PP ()
ppTkWord64 Word64
w
    TkWord64   Word64
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkWord     Word
w   Tokens
TkEnd     -> Word -> PP ()
ppTkWord Word
w
    TkWord     Word
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkBytes    ByteString
bs  Tokens
TkEnd     -> ByteString -> PP ()
ppTkBytes ByteString
bs
    TkBytes    ByteString
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkBytesBegin   Tokens
TkEnd     -> PP ()
ppTkBytesBegin
    TkBytesBegin   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkByteArray SlicedByteArray
ba Tokens
TkEnd     -> SlicedByteArray -> PP ()
ppTkByteArray SlicedByteArray
ba
    TkByteArray SlicedByteArray
_   Tokens
_        -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkUtf8ByteArray SlicedByteArray
ba Tokens
TkEnd -> SlicedByteArray -> PP ()
ppTkUtf8ByteArray SlicedByteArray
ba
    TkUtf8ByteArray SlicedByteArray
_   Tokens
_    -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkString   Text
t   Tokens
TkEnd     -> Text -> PP ()
ppTkString Text
t
    TkString   Text
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkStringBegin  Tokens
TkEnd     -> PP ()
ppTkStringBegin
    TkStringBegin  Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkListLen  Word
w   Tokens
TkEnd     -> Word -> PP ()
ppTkListLen Word
w
    TkListLen  Word
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkListBegin    Tokens
TkEnd     -> PP ()
ppTkListBegin
    TkListBegin    Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkMapLen   Word
w   Tokens
TkEnd     -> Word -> PP ()
ppTkMapLen Word
w
    TkMapLen   Word
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkMapBegin     Tokens
TkEnd     -> PP ()
ppTkMapBegin
    TkMapBegin     Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkBreak        Tokens
TkEnd     -> PP ()
ppTkBreak
    TkBreak        Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkTag      Word
w   Tokens
TkEnd     -> Word -> PP ()
ppTkTag Word
w
    TkTag      Word
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkTag64    Word64
w   Tokens
TkEnd     -> Word64 -> PP ()
ppTkTag64 Word64
w
    TkTag64    Word64
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkBool     Bool
b   Tokens
TkEnd     -> Bool -> PP ()
ppTkBool Bool
b
    TkBool     Bool
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkNull         Tokens
TkEnd     -> PP ()
ppTkNull
    TkNull         Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkUndef        Tokens
TkEnd     -> PP ()
ppTkUndef
    TkUndef        Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkSimple   Word8
w   Tokens
TkEnd     -> Word8 -> PP ()
ppTkSimple Word8
w
    TkSimple   Word8
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkFloat16  Float
f   Tokens
TkEnd     -> Float -> PP ()
ppTkFloat16 Float
f
    TkFloat16  Float
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkFloat32  Float
f   Tokens
TkEnd     -> Float -> PP ()
ppTkFloat32 Float
f
    TkFloat32  Float
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkFloat64  Double
f   Tokens
TkEnd     -> Double -> PP ()
ppTkFloat64 Double
f
    TkFloat64  Double
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    TkEncoded  ByteString
_   Tokens
TkEnd     -> PP ()
ppTkEncoded
    TkEncoded  ByteString
_   Tokens
_         -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
termFailure Tokens
term
    Tokens
TkEnd                    -> String -> PP ()
str String
"# End of input"
 where
   termFailure :: a -> m a
termFailure a
t = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"pprint: Unexpected token:", forall a. Show a => a -> String
show a
t]

ppTkInt        :: Int        -> PP ()
ppTkInt :: Int -> PP ()
ppTkInt Int
i = String -> PP ()
str String
"# int" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Int
i)

ppTkInt64      :: Int64      -> PP ()
ppTkInt64 :: Int64 -> PP ()
ppTkInt64 Int64
i = String -> PP ()
str String
"# int" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Int64
i)

ppTkInteger    :: Integer    -> PP ()
ppTkInteger :: Integer -> PP ()
ppTkInteger Integer
i = String -> PP ()
str String
"# integer" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Integer
i)

ppTkWord64     :: Word64     -> PP ()
ppTkWord64 :: Word64 -> PP ()
ppTkWord64 Word64
w = String -> PP ()
str String
"# word" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word64
w)

ppTkWord       :: Word       -> PP ()
ppTkWord :: Word -> PP ()
ppTkWord Word
w = String -> PP ()
str String
"# word" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word
w)

ppTkByteArray  :: SlicedByteArray -> PP ()
ppTkByteArray :: SlicedByteArray -> PP ()
ppTkByteArray SlicedByteArray
bs = String -> PP ()
str String
"# bytes" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown forall a b. (a -> b) -> a -> b
$ SlicedByteArray -> Int
sizeofSlicedByteArray SlicedByteArray
bs)

ppTkUtf8ByteArray  :: SlicedByteArray -> PP ()
ppTkUtf8ByteArray :: SlicedByteArray -> PP ()
ppTkUtf8ByteArray SlicedByteArray
bs = String -> PP ()
str String
"# text" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown forall a b. (a -> b) -> a -> b
$ SlicedByteArray -> Int
sizeofSlicedByteArray SlicedByteArray
bs)

ppTkBytes      :: S.ByteString -> PP ()
ppTkBytes :: ByteString -> PP ()
ppTkBytes ByteString
bs = String -> PP ()
str String
"# bytes" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown (ByteString -> Int
S.length ByteString
bs))

ppTkBytesBegin ::               PP ()
ppTkBytesBegin :: PP ()
ppTkBytesBegin = String -> PP ()
str String
"# bytes(*)" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> PP ()
inc Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP () -> PP ()
indef PP ()
pprint

ppTkString     :: T.Text     -> PP ()
ppTkString :: Text -> PP ()
ppTkString Text
t = String -> PP ()
str String
"# text" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Text
t)

ppTkStringBegin::               PP ()
ppTkStringBegin :: PP ()
ppTkStringBegin = String -> PP ()
str String
"# text(*)" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> PP ()
inc Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP () -> PP ()
indef PP ()
pprint

ppTkEncoded    ::               PP ()
ppTkEncoded :: PP ()
ppTkEncoded = String -> PP ()
str String
"# pre-encoded CBOR term"

ppTkListLen    :: Word       -> PP ()
ppTkListLen :: Word -> PP ()
ppTkListLen Word
n = do
  String -> PP ()
str String
"# list"
  forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word
n)
  Int -> PP ()
inc Int
3
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) PP ()
pprint
  Int -> PP ()
dec Int
3

ppTkListBegin  ::               PP ()
ppTkListBegin :: PP ()
ppTkListBegin = String -> PP ()
str String
"# list(*)" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> PP ()
inc Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP () -> PP ()
indef PP ()
pprint

ppMapPairs :: PP ()
ppMapPairs :: PP ()
ppMapPairs = do
  PP ()
nl
  Int -> PP ()
inc Int
3
  PP ()
indent
  String -> PP ()
str String
" # key"
  PP ()
pprint
  Int -> PP ()
dec Int
3
  -- str " [end map key]"
  PP ()
nl
  Int -> PP ()
inc Int
3
  PP ()
indent
  String -> PP ()
str String
" # value"
  PP ()
pprint
  Int -> PP ()
dec Int
3
  -- str " [end map value]"

ppTkMapLen     :: Word       -> PP ()
ppTkMapLen :: Word -> PP ()
ppTkMapLen Word
w = do
  String -> PP ()
str String
"# map"
  forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word
w)
  -- inc 3
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w) PP ()
ppMapPairs
  -- dec 3

ppTkMapBegin   ::               PP ()
ppTkMapBegin :: PP ()
ppTkMapBegin = String -> PP ()
str String
"# map(*)" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> PP ()
inc Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP () -> PP ()
indef PP ()
ppMapPairs

ppTkBreak      ::               PP ()
ppTkBreak :: PP ()
ppTkBreak = String -> PP ()
str String
"# break"

ppTkTag        :: Word       -> PP ()
ppTkTag :: Word -> PP ()
ppTkTag Word
w = do
  String -> PP ()
str String
"# tag"
  forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word
w)
  Int -> PP ()
inc Int
3
  PP ()
pprint
  Int -> PP ()
dec Int
3

ppTkTag64      :: Word64     -> PP ()
ppTkTag64 :: Word64 -> PP ()
ppTkTag64 Word64
w = do
  String -> PP ()
str String
"# tag"
  forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word64
w)
  Int -> PP ()
inc Int
3
  PP ()
pprint
  Int -> PP ()
dec Int
3

ppTkBool       :: Bool       -> PP ()
ppTkBool :: Bool -> PP ()
ppTkBool Bool
True = String -> PP ()
str String
"# bool" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (String -> PP ()
str String
"true")
ppTkBool Bool
False = String -> PP ()
str String
"# bool" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (String -> PP ()
str String
"false")

ppTkNull       ::               PP ()
ppTkNull :: PP ()
ppTkNull = String -> PP ()
str String
"# null"

ppTkUndef       ::              PP ()
ppTkUndef :: PP ()
ppTkUndef = String -> PP ()
str String
"# undefined"

ppTkSimple     :: Word8      -> PP ()
ppTkSimple :: Word8 -> PP ()
ppTkSimple Word8
w = String -> PP ()
str String
"# simple" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Word8
w)

ppTkFloat16    :: Float      -> PP ()
ppTkFloat16 :: Float -> PP ()
ppTkFloat16 Float
f = String -> PP ()
str String
"# float16" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Float
f)

ppTkFloat32    :: Float      -> PP ()
ppTkFloat32 :: Float -> PP ()
ppTkFloat32 Float
f = String -> PP ()
str String
"# float32" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Float
f)

ppTkFloat64    :: Double     -> PP ()
ppTkFloat64 :: Double -> PP ()
ppTkFloat64 Double
f = String -> PP ()
str String
"# float64" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. PP a -> PP a
parens (forall a. Show a => a -> PP ()
shown Double
f)

unconsToken :: Tokens -> Maybe (Tokens, Tokens)
unconsToken :: Tokens -> Maybe (Tokens, Tokens)
unconsToken Tokens
TkEnd               = forall a. Maybe a
Nothing
unconsToken (TkWord Word
w      Tokens
tks) = forall a. a -> Maybe a
Just (Word -> Tokens -> Tokens
TkWord Word
w      Tokens
TkEnd,Tokens
tks)
unconsToken (TkWord64 Word64
w    Tokens
tks) = forall a. a -> Maybe a
Just (Word64 -> Tokens -> Tokens
TkWord64 Word64
w    Tokens
TkEnd,Tokens
tks)
unconsToken (TkInt Int
i       Tokens
tks) = forall a. a -> Maybe a
Just (Int -> Tokens -> Tokens
TkInt Int
i       Tokens
TkEnd,Tokens
tks)
unconsToken (TkInt64 Int64
i     Tokens
tks) = forall a. a -> Maybe a
Just (Int64 -> Tokens -> Tokens
TkInt64 Int64
i     Tokens
TkEnd,Tokens
tks)
unconsToken (TkBytes ByteString
bs    Tokens
tks) = forall a. a -> Maybe a
Just (ByteString -> Tokens -> Tokens
TkBytes ByteString
bs    Tokens
TkEnd,Tokens
tks)
unconsToken (TkBytesBegin  Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkBytesBegin  Tokens
TkEnd,Tokens
tks)
unconsToken (TkByteArray SlicedByteArray
a Tokens
tks) = forall a. a -> Maybe a
Just (SlicedByteArray -> Tokens -> Tokens
TkByteArray SlicedByteArray
a Tokens
TkEnd,Tokens
tks)
unconsToken (TkString Text
t    Tokens
tks) = forall a. a -> Maybe a
Just (Text -> Tokens -> Tokens
TkString Text
t    Tokens
TkEnd,Tokens
tks)
unconsToken (TkStringBegin Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkStringBegin Tokens
TkEnd,Tokens
tks)
unconsToken (TkUtf8ByteArray SlicedByteArray
a Tokens
tks) = forall a. a -> Maybe a
Just (SlicedByteArray -> Tokens -> Tokens
TkUtf8ByteArray SlicedByteArray
a Tokens
TkEnd,Tokens
tks)
unconsToken (TkListLen Word
len Tokens
tks) = forall a. a -> Maybe a
Just (Word -> Tokens -> Tokens
TkListLen Word
len Tokens
TkEnd,Tokens
tks)
unconsToken (TkListBegin   Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkListBegin   Tokens
TkEnd,Tokens
tks)
unconsToken (TkMapLen Word
len  Tokens
tks) = forall a. a -> Maybe a
Just (Word -> Tokens -> Tokens
TkMapLen Word
len  Tokens
TkEnd,Tokens
tks)
unconsToken (TkMapBegin    Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkMapBegin    Tokens
TkEnd,Tokens
tks)
unconsToken (TkTag Word
w       Tokens
tks) = forall a. a -> Maybe a
Just (Word -> Tokens -> Tokens
TkTag Word
w       Tokens
TkEnd,Tokens
tks)
unconsToken (TkTag64 Word64
w64   Tokens
tks) = forall a. a -> Maybe a
Just (Word64 -> Tokens -> Tokens
TkTag64 Word64
w64   Tokens
TkEnd,Tokens
tks)
unconsToken (TkInteger Integer
i   Tokens
tks) = forall a. a -> Maybe a
Just (Integer -> Tokens -> Tokens
TkInteger Integer
i   Tokens
TkEnd,Tokens
tks)
unconsToken (TkNull        Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkNull        Tokens
TkEnd,Tokens
tks)
unconsToken (TkUndef       Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkUndef       Tokens
TkEnd,Tokens
tks)
unconsToken (TkBool Bool
b      Tokens
tks) = forall a. a -> Maybe a
Just (Bool -> Tokens -> Tokens
TkBool Bool
b      Tokens
TkEnd,Tokens
tks)
unconsToken (TkSimple Word8
w8   Tokens
tks) = forall a. a -> Maybe a
Just (Word8 -> Tokens -> Tokens
TkSimple Word8
w8   Tokens
TkEnd,Tokens
tks)
unconsToken (TkFloat16 Float
f16 Tokens
tks) = forall a. a -> Maybe a
Just (Float -> Tokens -> Tokens
TkFloat16 Float
f16 Tokens
TkEnd,Tokens
tks)
unconsToken (TkFloat32 Float
f32 Tokens
tks) = forall a. a -> Maybe a
Just (Float -> Tokens -> Tokens
TkFloat32 Float
f32 Tokens
TkEnd,Tokens
tks)
unconsToken (TkFloat64 Double
f64 Tokens
tks) = forall a. a -> Maybe a
Just (Double -> Tokens -> Tokens
TkFloat64 Double
f64 Tokens
TkEnd,Tokens
tks)
unconsToken (TkEncoded ByteString
bs  Tokens
tks) = forall a. a -> Maybe a
Just (ByteString -> Tokens -> Tokens
TkEncoded ByteString
bs  Tokens
TkEnd,Tokens
tks)
unconsToken (TkBreak       Tokens
tks) = forall a. a -> Maybe a
Just (Tokens -> Tokens
TkBreak       Tokens
TkEnd,Tokens
tks)

hexRep :: Tokens -> PP ()
hexRep :: Tokens -> PP ()
hexRep Tokens
tk = ByteString -> PP ()
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
toStrictByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tokens -> Tokens) -> Encoding
Encoding forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Tokens
tk where
  go :: ByteString -> PP ()
go ByteString
bs | ByteString -> Int
S.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
16 = case Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
16 ByteString
bs of
          (ByteString
h,ByteString
t) -> PP ()
indent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ShowS -> PP ()
appShowS (ByteString -> ShowS
hexBS ByteString
h) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PP ()
nl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> PP ()
go ByteString
t
        | Bool
otherwise = PP ()
indent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ShowS -> PP ()
appShowS (ByteString -> ShowS
hexBS ByteString
bs)

hexBS :: S.ByteString -> ShowS
hexBS :: ByteString -> ShowS
hexBS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Word8
n -> ((if Word8
n forall a. Ord a => a -> a -> Bool
< Word8
16 then (Char
'0'forall a. a -> [a] -> [a]
:) else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'forall a. a -> [a] -> [a]
:))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack