    {-# 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.Encoding
    import           Codec.CBOR.Write

    import qualified Control.Monad.Fail as Fail
    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/.
    --
    -- 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 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 = Fail.fail

    instance Fail.MonadFail PP where
      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 () -> PP ()
    indef pp = do
      tk <- peekTerm
      case tk of
        TkBreak TkEnd -> dec 3 >> pprint
        _ -> pp >> indef pp

    pprint :: PP ()
    pprint = do
      nl
      term <- getTerm
      hexRep term
      str " "
      case term of
        TkInt      i  TkEnd -> ppTkInt i
        TkInteger  i  TkEnd -> ppTkInteger i
        TkWord     w  TkEnd -> ppTkWord w
        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)

    ppTkWord       :: Word       -> PP ()
    ppTkWord w = str "# word" >> parens (shown w)

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

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

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

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

    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 pprint

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

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

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

    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 (TkByteArray a tks) = Just (TkByteArray a TkEnd,tks)
    unconsToken (TkString t    tks) = Just (TkString t    TkEnd,tks)
    unconsToken (TkStringBegin tks) = Just (TkStringBegin TkEnd,tks)
    unconsToken (TkUtf8ByteArray a tks) = Just (TkUtf8ByteArray a 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