{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{- |
Module      : Haskoin.Util
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

This module defines various utility functions used across the library.
-}
module Haskoin.Util (
    -- * ByteString Helpers
    bsToInteger,
    integerToBS,
    hexBuilder,
    encodeHex,
    encodeHexLazy,
    decodeHex,
    decodeHexLazy,
    getBits,

    -- * Maybe & Either Helpers
    eitherToMaybe,
    maybeToEither,
    liftEither,
    liftMaybe,

    -- * Other Helpers
    updateIndex,
    matchTemplate,
    convertBits,

    -- * Triples
    fst3,
    snd3,
    lst3,

    -- * JSON Utilities
    dropFieldLabel,
    dropSumLabels,

    -- * Serialization Helpers
    putList,
    getList,
    putMaybe,
    getMaybe,
    putLengthBytes,
    getLengthBytes,
    putInteger,
    getInteger,
    putInt32be,
    getInt32be,
    putInt64be,
    getInt64be,
    getIntMap,
    putIntMap,
    getTwo,
    putTwo,
) where

import Control.Monad
import Control.Monad.Except (ExceptT (..), liftEither)
import Data.Aeson.Types (
    Options (..),
    SumEncoding (..),
    defaultOptions,
    defaultTaggedObject,
 )
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Base16 as BL16
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Char (toLower)
import Data.Int
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List
import Data.Text (Text)
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as EL
import Data.Word

-- ByteString helpers

-- | Decode a big endian 'Integer' from a 'ByteString'.
bsToInteger :: ByteString -> Integer
bsToInteger :: ByteString -> Integer
bsToInteger = (Word8 -> Integer -> Integer) -> Integer -> ByteString -> Integer
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr Word8 -> Integer -> Integer
forall a. Integral a => a -> Integer -> Integer
f Integer
0 (ByteString -> Integer)
-> (ByteString -> ByteString) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse
  where
    f :: a -> Integer -> Integer
f a
w Integer
n = a -> Integer
forall a. Integral a => a -> Integer
toInteger a
w Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
n Int
8

-- | Encode an 'Integer' to a 'ByteString' as big endian.
integerToBS :: Integer -> ByteString
integerToBS :: Integer -> ByteString
integerToBS Integer
0 = [Word8] -> ByteString
BS.pack [Word8
0]
integerToBS Integer
i
    | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 = ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Integer -> Maybe (Word8, Integer)) -> Integer -> ByteString
forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr Integer -> Maybe (Word8, Integer)
f Integer
i
    | Bool
otherwise = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"integerToBS not defined for negative values"
  where
    f :: Integer -> Maybe (Word8, Integer)
f Integer
0 = Maybe (Word8, Integer)
forall a. Maybe a
Nothing
    f Integer
x = (Word8, Integer) -> Maybe (Word8, Integer)
forall a. a -> Maybe a
Just (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
x :: Word8, Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

hexBuilder :: BL.ByteString -> Builder
hexBuilder :: ByteString -> Builder
hexBuilder = ByteString -> Builder
lazyByteStringHex

encodeHex :: ByteString -> Text
encodeHex :: ByteString -> Text
encodeHex = ByteString -> Text
B16.encodeBase16

-- | Encode as string of human-readable hex characters.
encodeHexLazy :: BL.ByteString -> TL.Text
encodeHexLazy :: ByteString -> Text
encodeHexLazy = ByteString -> Text
BL16.encodeBase16

decodeHex :: Text -> Maybe ByteString
decodeHex :: Text -> Maybe ByteString
decodeHex = Either Text ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either Text ByteString -> Maybe ByteString)
-> (Text -> Either Text ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
B16.decodeBase16 (ByteString -> Either Text ByteString)
-> (Text -> ByteString) -> Text -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8

-- | Decode string of human-readable hex characters.
decodeHexLazy :: TL.Text -> Maybe BL.ByteString
decodeHexLazy :: Text -> Maybe ByteString
decodeHexLazy = Either Text ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either Text ByteString -> Maybe ByteString)
-> (Text -> Either Text ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
BL16.decodeBase16 (ByteString -> Either Text ByteString)
-> (Text -> ByteString) -> Text -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
EL.encodeUtf8

{- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString'
 will be smallest required to hold that many bits, padded with zeroes to the
 right.
-}
getBits :: Int -> ByteString -> ByteString
getBits :: Int -> ByteString -> ByteString
getBits Int
b ByteString
bs
    | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> ByteString -> ByteString
BS.take Int
q ByteString
bs
    | Bool
otherwise = ByteString
i ByteString -> Word8 -> ByteString
`BS.snoc` Word8
l
  where
    (Int
q, Int
r) = Int
b Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
8
    s :: ByteString
s = Int -> ByteString -> ByteString
BS.take (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs
    i :: ByteString
i = ByteString -> ByteString
BS.init ByteString
s
    l :: Word8
l = ByteString -> Word8
BS.last ByteString
s Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
0xff Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)) -- zero unneeded bits

-- Maybe and Either monad helpers

{- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to
 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost.
-}
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Right b
b) = b -> Maybe b
forall a. a -> Maybe a
Just b
b
eitherToMaybe Either a b
_ = Maybe b
forall a. Maybe a
Nothing

{- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to
 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required.
-}
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither b
err = Either b a -> (a -> Either b a) -> Maybe a -> Either b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> Either b a
forall a b. a -> Either a b
Left b
err) a -> Either b a
forall a b. b -> Either a b
Right

-- | Lift a 'Maybe' computation into the 'ExceptT' monad.
liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a
liftMaybe :: b -> Maybe a -> ExceptT b m a
liftMaybe b
err = Either b a -> ExceptT b m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either b a -> ExceptT b m a)
-> (Maybe a -> Either b a) -> Maybe a -> ExceptT b m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe a -> Either b a
forall b a. b -> Maybe a -> Either b a
maybeToEither b
err

-- Various helpers

{- | Applies a function to only one element of a list defined by its index.  If
 the index is out of the bounds of the list, the original list is returned.
-}
updateIndex ::
    -- | index of the element to change
    Int ->
    -- | list of elements
    [a] ->
    -- | function to apply
    (a -> a) ->
    -- | result with one element changed
    [a]
updateIndex :: Int -> [a] -> (a -> a) -> [a]
updateIndex Int
i [a]
xs a -> a
f
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = [a]
xs
    | Bool
otherwise = [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> a
f a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
r)
  where
    ([a]
l, a
h : [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs

{- | Use the list @[b]@ as a template and try to match the elements of @[a]@
 against it. For each element of @[b]@ return the (first) matching element of
 @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results
 in same order. Elements of @[a]@ can only appear once.
-}
matchTemplate ::
    -- | input list
    [a] ->
    -- | list to serve as a template
    [b] ->
    -- | comparison function
    (a -> b -> Bool) ->
    [Maybe a]
matchTemplate :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [] [b]
bs a -> b -> Bool
_ = Int -> Maybe a -> [Maybe a]
forall a. Int -> a -> [a]
replicate ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
bs) Maybe a
forall a. Maybe a
Nothing
matchTemplate [a]
_ [] a -> b -> Bool
_ = []
matchTemplate [a]
as (b
b : [b]
bs) a -> b -> Bool
f = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> b -> Bool
`f` b
b) [a]
as of
    ([a]
l, a
r : [a]
rs) -> a -> Maybe a
forall a. a -> Maybe a
Just a
r Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate ([a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rs) [b]
bs a -> b -> Bool
f
    ([a], [a])
_ -> Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [a]
as [b]
bs a -> b -> Bool
f

-- | Returns the first value of a triple.
fst3 :: (a, b, c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

-- | Returns the second value of a triple.
snd3 :: (a, b, c) -> b
snd3 :: (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b

-- | Returns the last value of a triple.
lst3 :: (a, b, c) -> c
lst3 :: (a, b, c) -> c
lst3 (a
_, b
_, c
c) = c
c

-- | Field label goes lowercase and first @n@ characters get removed.
dropFieldLabel :: Int -> Options
dropFieldLabel :: Int -> Options
dropFieldLabel Int
n =
    Options
defaultOptions
        { fieldLabelModifier :: [Char] -> [Char]
fieldLabelModifier = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n
        }

{- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus
 constructor tags are lowercased and first @c@ characters removed. @tag@ is
 used as the name of the object field name that will hold the transformed
 constructor tag as its value.
-}
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels :: Int -> Int -> [Char] -> Options
dropSumLabels Int
c Int
f [Char]
tag =
    (Int -> Options
dropFieldLabel Int
f)
        { constructorTagModifier :: [Char] -> [Char]
constructorTagModifier = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
c
        , sumEncoding :: SumEncoding
sumEncoding = SumEncoding
defaultTaggedObject{tagFieldName :: [Char]
tagFieldName = [Char]
tag}
        }

{- | Convert from one power-of-two base to another, as long as it fits in a
 'Word'.
-}
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits Bool
pad Int
frombits Int
tobits [Word]
i = ([Word] -> [Word]
forall a. [a] -> [a]
reverse [Word]
yout, Bool
rem')
  where
    (Word
xacc, Int
xbits, [Word]
xout) = ((Word, Int, [Word]) -> Word -> (Word, Int, [Word]))
-> (Word, Int, [Word]) -> [Word] -> (Word, Int, [Word])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Int, [Word]) -> Word -> (Word, Int, [Word])
outer (Word
0, Int
0, []) [Word]
i
    ([Word]
yout, Bool
rem')
        | Bool
pad Bool -> Bool -> Bool
&& Int
xbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 =
            let xout' :: [Word]
xout' = (Word
xacc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` (Int
tobits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xbits)) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
maxv Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word]
xout
             in ([Word]
xout', Bool
False)
        | Bool
pad = ([Word]
xout, Bool
False)
        | Int
xbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = ([Word]
xout, Bool
True)
        | Bool
otherwise = ([Word]
xout, Bool
False)
    maxv :: Word
maxv = Word
1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
tobits Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1
    max_acc :: Word
max_acc = Word
1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` (Int
frombits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tobits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1
    outer :: (Word, Int, [Word]) -> Word -> (Word, Int, [Word])
outer (Word
acc, Int
bits, [Word]
out) Word
it =
        let acc' :: Word
acc' = ((Word
acc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
frombits) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
it) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
max_acc
            bits' :: Int
bits' = Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frombits
            ([Word]
out', Int
bits'') = Word -> [Word] -> Int -> ([Word], Int)
inner Word
acc' [Word]
out Int
bits'
         in (Word
acc', Int
bits'', [Word]
out')
    inner :: Word -> [Word] -> Int -> ([Word], Int)
inner Word
acc [Word]
out Int
bits
        | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tobits =
            let bits' :: Int
bits' = Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tobits
                out' :: [Word]
out' = ((Word
acc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits') Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
maxv) Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word]
out
             in Word -> [Word] -> Int -> ([Word], Int)
inner Word
acc [Word]
out' Int
bits'
        | Bool
otherwise = ([Word]
out, Int
bits)

--
-- Serialization helpers
--

putInt32be :: MonadPut m => Int32 -> m ()
putInt32be :: Int32 -> m ()
putInt32be Int32
n
    | Int32
n Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0 = Word32 -> m ()
forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (Word32 -> Word32
forall a. Bits a => a -> a
complement (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32
forall a. Num a => a -> a
abs Int32
n)) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)
    | Bool
otherwise = Word32 -> m ()
forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32
forall a. Num a => a -> a
abs Int32
n))

getInt32be :: MonadGet m => m Int32
getInt32be :: m Int32
getInt32be = do
    Word32
n <- m Word32
forall (m :: * -> *). MonadGet m => m Word32
getWord32be
    if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
n Int
31
        then Int32 -> m Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> Int32
forall a. Num a => a -> a
negate (Int32 -> Int32
forall a. Bits a => a -> a
complement (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1))
        else Int32 -> m Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n)

putInt64be :: MonadPut m => Int64 -> m ()
putInt64be :: Int64 -> m ()
putInt64be Int64
n
    | Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 = Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Word64 -> Word64
forall a. Bits a => a -> a
complement (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int64
forall a. Num a => a -> a
abs Int64
n)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
    | Bool
otherwise = Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int64
forall a. Num a => a -> a
abs Int64
n))

getInt64be :: MonadGet m => m Int64
getInt64be :: m Int64
getInt64be = do
    Word64
n <- m Word64
forall (m :: * -> *). MonadGet m => m Word64
getWord64be
    if Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
n Int
63
        then Int64 -> m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Int64
forall a. Num a => a -> a
negate (Int64 -> Int64
forall a. Bits a => a -> a
complement (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1))
        else Int64 -> m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)

putInteger :: MonadPut m => Integer -> m ()
putInteger :: Integer -> m ()
putInteger Integer
n
    | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
lo Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
hi = do
        Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 Word8
0x00
        Int32 -> m ()
forall (m :: * -> *). MonadPut m => Int32 -> m ()
putInt32be (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
    | Bool
otherwise = do
        Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 Word8
0x01
        Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer
forall a. Num a => a -> a
signum Integer
n))
        let len :: Int
len = (Integer -> Int
forall a. (Ord a, Integral a) => a -> Int
nrBits (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
        Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        (Word8 -> m ()) -> [Word8] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 (Integer -> [Word8]
forall a. (Integral a, Bits a) => a -> [Word8]
unroll (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n))
  where
    lo :: Integer
lo = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: Int32)
    hi :: Integer
hi = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32)

getInteger :: MonadGet m => m Integer
getInteger :: m Integer
getInteger =
    m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8 m Word8 -> (Word8 -> m Integer) -> m Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Integer) -> m Int32 -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int32
forall (m :: * -> *). MonadGet m => m Int32
getInt32be
        Word8
_ -> do
            Word8
sign <- m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8
            [Word8]
bytes <- m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadGet m => m a -> m [a]
getList m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8
            let v :: Integer
v = [Word8] -> Integer
forall a. (Integral a, Bits a) => [Word8] -> a
roll [Word8]
bytes
            Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$! if Word8
sign Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x01 then Integer
v else - Integer
v

putMaybe :: MonadPut m => (a -> m ()) -> Maybe a -> m ()
putMaybe :: (a -> m ()) -> Maybe a -> m ()
putMaybe a -> m ()
f Maybe a
Nothing = Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 Word8
0x00
putMaybe a -> m ()
f (Just a
x) = Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 Word8
0x01 m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
f a
x

getMaybe :: MonadGet m => m a -> m (Maybe a)
getMaybe :: m a -> m (Maybe a)
getMaybe m a
f =
    m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8 m Word8 -> (Word8 -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0x00 -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Word8
0x01 -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f
        Word8
_ -> [Char] -> m (Maybe a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Not a Maybe"

putLengthBytes :: MonadPut m => ByteString -> m ()
putLengthBytes :: ByteString -> m ()
putLengthBytes ByteString
bs = do
    Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))
    ByteString -> m ()
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString ByteString
bs

getLengthBytes :: MonadGet m => m ByteString
getLengthBytes :: m ByteString
getLengthBytes = do
    Int
len <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> m Word64 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadGet m => m Word64
getWord64be
    Int -> m ByteString
forall (m :: * -> *). MonadGet m => Int -> m ByteString
getByteString Int
len

--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll :: a -> [Word8]
unroll = (a -> Maybe (Word8, a)) -> a -> [Word8]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr a -> Maybe (Word8, a)
forall b a. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
step
  where
    step :: b -> Maybe (a, b)
step b
0 = Maybe (a, b)
forall a. Maybe a
Nothing
    step b
i = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i, b
i b -> Int -> b
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

roll :: (Integral a, Bits a) => [Word8] -> a
roll :: [Word8] -> a
roll = (Word8 -> a -> a) -> a -> [Word8] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> a -> a
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
unstep a
0
  where
    unstep :: a -> a -> a
unstep a
b a
a = a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b

nrBits :: (Ord a, Integral a) => a -> Int
nrBits :: a -> Int
nrBits a
k =
    let expMax :: Int
expMax = (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until (\Int
e -> a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
k) (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Int
1
        findNr :: Int -> Int -> Int
        findNr :: Int -> Int -> Int
findNr Int
lo Int
hi
            | Int
mid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = Int
hi
            | a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
mid a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
k = Int -> Int -> Int
findNr Int
mid Int
hi
            | a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
mid a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
k = Int -> Int -> Int
findNr Int
lo Int
mid
          where
            mid :: Int
mid = (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hi) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
     in Int -> Int -> Int
findNr (Int
expMax Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int
expMax

-- | Read as a list of pairs of int and element.
getIntMap :: MonadGet m => m Int -> m a -> m (IntMap a)
getIntMap :: m Int -> m a -> m (IntMap a)
getIntMap m Int
i m a
m = [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, a)] -> IntMap a) -> m [(Int, a)] -> m (IntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Int, a) -> m [(Int, a)]
forall (m :: * -> *) a. MonadGet m => m a -> m [a]
getList (m Int -> m a -> m (Int, a)
forall (m :: * -> *) a b. MonadGet m => m a -> m b -> m (a, b)
getTwo m Int
i m a
m)

putIntMap :: MonadPut m => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m ()
putIntMap :: (Int -> m ()) -> (a -> m ()) -> IntMap a -> m ()
putIntMap Int -> m ()
f a -> m ()
g = ((Int, a) -> m ()) -> [(Int, a)] -> m ()
forall (m :: * -> *) a. MonadPut m => (a -> m ()) -> [a] -> m ()
putList ((Int -> m ()) -> (a -> m ()) -> (Int, a) -> m ()
forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo Int -> m ()
f a -> m ()
g) ([(Int, a)] -> m ())
-> (IntMap a -> [(Int, a)]) -> IntMap a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList

putTwo :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo :: (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo a -> m ()
f b -> m ()
g (a
x, b
y) = a -> m ()
f a
x m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m ()
g b
y

getTwo :: MonadGet m => m a -> m b -> m (a, b)
getTwo :: m a -> m b -> m (a, b)
getTwo m a
f m b
g = (,) (a -> b -> (a, b)) -> m a -> m (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f m (b -> (a, b)) -> m b -> m (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m b
g

putList :: MonadPut m => (a -> m ()) -> [a] -> m ()
putList :: (a -> m ()) -> [a] -> m ()
putList a -> m ()
f [a]
ls = do
    Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls))
    (a -> m ()) -> [a] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> m ()
f [a]
ls

getList :: MonadGet m => m a -> m [a]
getList :: m a -> m [a]
getList m a
f = do
    Int
l <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> m Word64 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadGet m => m Word64
getWord64be
    Int -> m a -> m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l m a
f