{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Text.Bytes
( Bytes
, Binary(fromBytes, intoBytes)
, hOutput
, chunk
) where
import Data.Bits (Bits (..))
import Data.Char (intToDigit)
import qualified Data.ByteString as B (ByteString, foldl', splitAt
, pack, unpack, length, hPut)
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as L (ByteString, fromStrict, toStrict)
import Data.Hashable (Hashable)
import qualified Data.List as List
import Data.Word (Word8)
import GHC.Generics (Generic)
import Data.Text.Prettyprint.Doc
( Doc, emptyDoc, pretty, annotate, (<+>), hsep, vcat
, space, punctuate, hcat, group, flatAlt, sep, fillSep
, line, line', softline, softline', hardline
)
import Data.Text.Prettyprint.Doc.Render.Terminal (
color, colorDull, bold, Color(..))
import System.IO (Handle)
import Core.Text.Utilities
data Bytes
= StrictBytes B.ByteString
deriving (Show, Eq, Ord, Generic)
instance Hashable Bytes
class Binary α where
fromBytes :: Bytes -> α
intoBytes :: α -> Bytes
instance Binary B.ByteString where
fromBytes (StrictBytes b') = b'
intoBytes b' = StrictBytes b'
instance Binary L.ByteString where
fromBytes (StrictBytes b') = L.fromStrict b'
intoBytes b' = StrictBytes (L.toStrict b')
instance Binary [Word8] where
fromBytes (StrictBytes b') = B.unpack b'
intoBytes = StrictBytes . B.pack
hOutput :: Handle -> Bytes -> IO ()
hOutput handle (StrictBytes b') = B.hPut handle b'
instance Render Bytes where
type Token Bytes = ()
colourize = const (color Green)
intoDocA = prettyBytes
prettyBytes :: Bytes -> Doc ()
prettyBytes (StrictBytes b') = annotate () . vcat . twoWords
. fmap wordToHex . chunk $ b'
twoWords :: [Doc ann] -> [Doc ann]
twoWords ds = go ds
where
go [] = []
go [x] = [softline' <> x]
go xs =
let
(one:two:[], remainder) = List.splitAt 2 xs
in
group (one <> spacer <> two) : go remainder
spacer = flatAlt softline' " "
chunk :: B.ByteString -> [B.ByteString]
chunk = reverse . go []
where
go acc blob =
let
(eight, remainder) = B.splitAt 8 blob
in
if B.length remainder == 0
then eight : acc
else go (eight : acc) remainder
wordToHex :: B.ByteString -> Doc ann
wordToHex eight =
let
ws = B.unpack eight
ds = fmap byteToHex ws
in
hsep ds
byteToHex :: Word8 -> Doc ann
byteToHex c = pretty hi <> pretty low
where
!low = byteToDigit $ c .&. 0xf
!hi = byteToDigit $ (c .&. 0xf0) `shiftR` 4
byteToDigit :: Word8 -> Char
byteToDigit = intToDigit . fromIntegral