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

-- |
-- 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.Base16.Types (assertBase16, extractBase16)
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Base16 qualified 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 Data.IntMap qualified as IntMap
import Data.List
import Data.Text (Text)
import Data.Text.Encoding qualified as E
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as EL
import Data.Word

-- ByteString helpers

-- | Decode a big endian 'Integer' from a 'ByteString'.
bsToInteger :: ByteString -> Integer
bsToInteger :: ByteString -> Integer
bsToInteger = forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr forall {a}. Integral a => a -> Integer -> Integer
f Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse
  where
    f :: a -> Integer -> Integer
f a
w Integer
n = forall a. Integral a => a -> Integer
toInteger a
w forall a. Bits a => a -> a -> a
.|. 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 forall a. Ord a => a -> a -> Bool
> Integer
0 = ByteString -> ByteString
BS.reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr Integer -> Maybe (Word8, Integer)
f Integer
i
  | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"integerToBS not defined for negative values"
  where
    f :: Integer -> Maybe (Word8, Integer)
f Integer
0 = forall a. Maybe a
Nothing
    f Integer
x = forall a. a -> Maybe a
Just (forall a. Num a => Integer -> a
fromInteger Integer
x :: Word8, Integer
x 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 = forall a. Base16 a -> a
extractBase16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 Text
B16.encodeBase16

-- | Encode as string of human-readable hex characters.
encodeHexLazy :: BL.ByteString -> TL.Text
encodeHexLazy :: ByteString -> Text
encodeHexLazy = forall a. Base16 a -> a
extractBase16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 Text
BL16.encodeBase16

decodeHex :: Text -> Maybe ByteString
decodeHex :: Text -> Maybe ByteString
decodeHex Text
t =
  if ByteString -> Bool
B16.isBase16 ByteString
u8
    then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base16 ByteString -> ByteString
B16.decodeBase16 forall a b. (a -> b) -> a -> b
$ forall a. a -> Base16 a
assertBase16 ByteString
u8
    else forall a. Maybe a
Nothing
  where
    u8 :: ByteString
u8 = Text -> ByteString
E.encodeUtf8 Text
t

-- | Decode string of human-readable hex characters.
decodeHexLazy :: TL.Text -> Maybe BL.ByteString
decodeHexLazy :: Text -> Maybe ByteString
decodeHexLazy Text
t = 
    if ByteString -> Bool
BL16.isBase16 ByteString
u8
        then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base16 ByteString -> ByteString
BL16.decodeBase16 forall a b. (a -> b) -> a -> b
$ forall a. a -> Base16 a
assertBase16 ByteString
u8
        else forall a. Maybe a
Nothing
  where
    u8 :: ByteString
u8 = Text -> ByteString
EL.encodeUtf8 Text
t

-- | 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 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 forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
8
    s :: ByteString
s = Int -> ByteString -> ByteString
BS.take (Int
q forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs
    i :: ByteString
i = HasCallStack => ByteString -> ByteString
BS.init ByteString
s
    l :: Word8
l = HasCallStack => ByteString -> Word8
BS.last ByteString
s forall a. Bits a => a -> a -> a
.&. (Word8
0xff forall a. Bits a => a -> Int -> a
`shiftL` (Int
8 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 :: forall a b. Either a b -> Maybe b
eitherToMaybe (Right b
b) = forall a. a -> Maybe a
Just b
b
eitherToMaybe Either a 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 :: forall b a. b -> Maybe a -> Either b a
maybeToEither b
err = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left b
err) 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 :: forall (m :: * -> *) b a. Monad m => b -> Maybe a -> ExceptT b m a
liftMaybe b
err = forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Int -> [a] -> (a -> a) -> [a]
updateIndex Int
i [a]
xs a -> a
f
  | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = [a]
xs
  | Bool
otherwise = [a]
l forall a. [a] -> [a] -> [a]
++ (a -> a
f a
h forall a. a -> [a] -> [a]
: [a]
r)
  where
    ([a]
l, a
h : [a]
r) = 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 :: forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [] [b]
bs a -> b -> Bool
_ = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
bs) forall a. Maybe a
Nothing
matchTemplate [a]
_ [] a -> b -> Bool
_ = []
matchTemplate [a]
as (b
b : [b]
bs) a -> b -> Bool
f = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> b -> Bool
`f` b
b) [a]
as of
  ([a]
l, a
r : [a]
rs) -> forall a. a -> Maybe a
Just a
r forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate ([a]
l forall a. [a] -> [a] -> [a]
++ [a]
rs) [b]
bs a -> b -> Bool
f
  ([a], [a])
_ -> forall a. Maybe a
Nothing forall a. a -> [a] -> [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 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

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

-- | Returns the last value of a triple.
lst3 :: (a, b, c) -> c
lst3 :: forall a b c. (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 = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (forall a. [a] -> [a]
reverse [Word]
yout, Bool
rem')
  where
    (Word
xacc, Int
xbits, [Word]
xout) = 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 forall a. Eq a => a -> a -> Bool
/= Int
0 =
          let xout' :: [Word]
xout' = (Word
xacc forall a. Bits a => a -> Int -> a
`shiftL` (Int
tobits forall a. Num a => a -> a -> a
- Int
xbits)) forall a. Bits a => a -> a -> a
.&. Word
maxv forall a. a -> [a] -> [a]
: [Word]
xout
           in ([Word]
xout', Bool
False)
      | Bool
pad = ([Word]
xout, Bool
False)
      | Int
xbits forall a. Eq a => a -> a -> Bool
/= Int
0 = ([Word]
xout, Bool
True)
      | Bool
otherwise = ([Word]
xout, Bool
False)
    maxv :: Word
maxv = Word
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
tobits forall a. Num a => a -> a -> a
- Word
1
    max_acc :: Word
max_acc = Word
1 forall a. Bits a => a -> Int -> a
`shiftL` (Int
frombits forall a. Num a => a -> a -> a
+ Int
tobits forall a. Num a => a -> a -> a
- Int
1) 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 forall a. Bits a => a -> Int -> a
`shiftL` Int
frombits) forall a. Bits a => a -> a -> a
.|. Word
it) forall a. Bits a => a -> a -> a
.&. Word
max_acc
          bits' :: Int
bits' = Int
bits 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 forall a. Ord a => a -> a -> Bool
>= Int
tobits =
          let bits' :: Int
bits' = Int
bits forall a. Num a => a -> a -> a
- Int
tobits
              out' :: [Word]
out' = ((Word
acc forall a. Bits a => a -> Int -> a
`shiftR` Int
bits') forall a. Bits a => a -> a -> a
.&. Word
maxv) 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 :: forall (m :: * -> *). MonadPut m => Int32 -> m ()
putInt32be Int32
n
  | Int32
n forall a. Ord a => a -> a -> Bool
< Int32
0 = forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (forall a. Bits a => a -> a
complement (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
abs Int32
n)) forall a. Num a => a -> a -> a
+ Word32
1)
  | Bool
otherwise = forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
abs Int32
n))

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

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

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

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

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

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

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

getLengthBytes :: (MonadGet m) => m ByteString
getLengthBytes :: forall (m :: * -> *). MonadGet m => m ByteString
getLengthBytes = do
  Int
len <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGet m => m Word64
getWord64be
  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 :: forall a. (Integral a, Bits a) => a -> [Word8]
unroll = forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr forall {b} {a}. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
step
  where
    step :: b -> Maybe (a, b)
step b
0 = forall a. Maybe a
Nothing
    step b
i = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i, b
i forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

roll :: (Integral a, Bits a) => [Word8] -> a
roll :: forall a. (Integral a, Bits a) => [Word8] -> a
roll = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b

nrBits :: (Ord a, Integral a) => a -> Int
nrBits :: forall a. (Ord a, Integral a) => a -> Int
nrBits a
k =
  let expMax :: Int
expMax = forall a. (a -> Bool) -> (a -> a) -> a -> a
until (\Int
e -> a
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e forall a. Ord a => a -> a -> Bool
> a
k) (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 forall a. Eq a => a -> a -> Bool
== Int
lo = Int
hi
        | a
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
mid forall a. Ord a => a -> a -> Bool
<= a
k = Int -> Int -> Int
findNr Int
mid Int
hi
        | a
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
mid forall a. Ord a => a -> a -> Bool
> a
k = Int -> Int -> Int
findNr Int
lo Int
mid
        where
          mid :: Int
mid = (Int
lo forall a. Num a => a -> a -> a
+ Int
hi) forall a. Integral a => a -> a -> a
`div` Int
2
   in Int -> Int -> Int
findNr (Int
expMax 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 :: forall (m :: * -> *) a. MonadGet m => m Int -> m a -> m (IntMap a)
getIntMap m Int
i m a
m = forall a. [(Int, a)] -> IntMap a
IntMap.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadGet m => m a -> m [a]
getList (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 :: forall (m :: * -> *) a.
MonadPut m =>
(Int -> m ()) -> (a -> m ()) -> IntMap a -> m ()
putIntMap Int -> m ()
f a -> m ()
g = forall (m :: * -> *) a. MonadPut m => (a -> m ()) -> [a] -> m ()
putList (forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo Int -> m ()
f a -> m ()
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IntMap.toAscList

putTwo :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo :: forall (m :: * -> *) a b.
MonadPut m =>
(a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo a -> m ()
f b -> m ()
g (a
x, b
y) = a -> m ()
f a
x 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 :: forall (m :: * -> *) a b. MonadGet m => m a -> m b -> m (a, b)
getTwo m a
f m b
g = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m b
g

putList :: (MonadPut m) => (a -> m ()) -> [a] -> m ()
putList :: forall (m :: * -> *) a. MonadPut m => (a -> m ()) -> [a] -> m ()
putList a -> m ()
f [a]
ls = do
  forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls))
  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 :: forall (m :: * -> *) a. MonadGet m => m a -> m [a]
getList m a
f = do
  Int
l <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadGet m => m Word64
getWord64be
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l m a
f