{-# 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 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 w :: a
w n :: 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 8

-- | Encode an 'Integer' to a 'ByteString' as big endian.
integerToBS :: Integer -> ByteString
integerToBS :: Integer -> ByteString
integerToBS 0 = [Word8] -> ByteString
BS.pack [0]
integerToBS i :: Integer
i
    | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 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 "integerToBS not defined for negative values"
  where
    f :: Integer -> Maybe (Word8, Integer)
f 0 = Maybe (Word8, Integer)
forall a. Maybe a
Nothing
    f x :: 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` 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 b :: Int
b bs :: ByteString
bs
    | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int -> ByteString -> ByteString
BS.take Int
q ByteString
bs
    | Bool
otherwise = ByteString
i ByteString -> Word8 -> ByteString
`BS.snoc` Word8
l
  where
    (q :: Int
q, r :: Int
r) = Int
b Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 8
    s :: ByteString
s = Int -> ByteString -> ByteString
BS.take (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
.&. (0xff Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` (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) = b -> Maybe b
forall a. a -> Maybe a
Just b
b
eitherToMaybe _         = 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 err :: 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 err :: 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 :: Int      -- ^ index of the element to change
            -> [a]      -- ^ list of elements
            -> (a -> a) -- ^ function to apply
            -> [a]      -- ^ result with one element changed
updateIndex :: Int -> [a] -> (a -> a) -> [a]
updateIndex i :: Int
i xs :: [a]
xs f :: a -> a
f
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
    (l :: [a]
l,h :: a
h:r :: [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 :: [a]              -- ^ input list
              -> [b]              -- ^ list to serve as a template
              -> (a -> b -> Bool) -- ^ comparison function
              -> [Maybe a]
matchTemplate :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [] bs :: [b]
bs _ = 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 _  [] _ = []
matchTemplate as :: [a]
as (b :: b
b:bs :: [b]
bs) f :: 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
    (l :: [a]
l,r :: a
r:rs :: [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
    _        -> 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
a,_,_) = a
a

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

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

-- | Field label goes lowercase and first @n@ characters get removed.
dropFieldLabel :: Int -> Options
dropFieldLabel :: Int -> Options
dropFieldLabel n :: 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 c :: Int
c f :: Int
f tag :: [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 pad :: Bool
pad frombits :: Int
frombits tobits :: Int
tobits i :: [Word]
i = ([Word] -> [Word]
forall a. [a] -> [a]
reverse [Word]
yout, Bool
rem')
  where
    (xacc :: Word
xacc, xbits :: Int
xbits, xout :: [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 (0, 0, []) [Word]
i
    (yout :: [Word]
yout, rem' :: Bool
rem')
        | Bool
pad Bool -> Bool -> Bool
&& Int
xbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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
/= 0 = ([Word]
xout, Bool
True)
        | Bool
otherwise = ([Word]
xout, Bool
False)
    maxv :: Word
maxv = 1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
tobits Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1
    max_acc :: Word
max_acc = 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
- 1) Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1
    outer :: (Word, Int, [Word]) -> Word -> (Word, Int, [Word])
outer (acc :: Word
acc, bits :: Int
bits, out :: [Word]
out) it :: 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
            (out' :: [Word]
out', bits'' :: 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 acc :: Word
acc out :: [Word]
out bits :: 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 n :: Int32
n
    | Int32
n Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+ 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 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
+ 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 n :: Int64
n
    | Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+ 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 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
+ 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 n :: 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 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 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
+ 7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
    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
    _ -> 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
== 0x01 then Integer
v else - Integer
v

putMaybe :: MonadPut m => (a -> m ()) -> Maybe a -> m ()
putMaybe :: (a -> m ()) -> Maybe a -> m ()
putMaybe f :: a -> m ()
f Nothing  = Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 0x00
putMaybe f :: a -> m ()
f (Just x :: a
x) = Word8 -> m ()
forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8 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 f :: 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
    0x00 -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    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
    _    -> [Char] -> m (Maybe a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "Not a Maybe"

putLengthBytes :: MonadPut m => ByteString -> m ()
putLengthBytes :: ByteString -> m ()
putLengthBytes bs :: 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 0 = Maybe (a, b)
forall a. Maybe a
Nothing
    step i :: 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` 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 0
  where
    unstep :: a -> a -> a
unstep b :: a
b a :: a
a = a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` 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 k :: a
k =
    let expMax :: Int
expMax = (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until (\e :: Int
e -> 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
* 2) 1
        findNr :: Int -> Int -> Int
        findNr :: Int -> Int -> Int
findNr lo :: Int
lo hi :: Int
hi
            | Int
mid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = Int
hi
            | 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
            | 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` 2
    in Int -> Int -> Int
findNr (Int
expMax Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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 i :: m Int
i m :: 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 f :: Int -> m ()
f g :: 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 f :: a -> m ()
f g :: b -> m ()
g (x :: a
x, y :: 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 f :: m a
f g :: 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 f :: a -> m ()
f ls :: [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 f :: 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