{-# LANGUAGE CPP #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Haskoin.Util.Helpers
(
bsToInteger,
integerToBS,
hexEncoding,
hexBuilder,
encodeHex,
encodeHexLazy,
decodeHex,
decodeHexLazy,
getBits,
eitherToMaybe,
maybeToEither,
liftEither,
liftMaybe,
updateIndex,
matchTemplate,
convertBits,
fst3,
snd3,
lst3,
dropFieldLabel,
dropSumLabels,
putList,
getList,
putMaybe,
getMaybe,
putLengthBytes,
getLengthBytes,
putInteger,
getInteger,
putInt32be,
getInt32be,
putInt64be,
getInt64be,
getIntMap,
putIntMap,
getTwo,
putTwo,
prepareContext,
customCerealID,
readTestFile,
readTestFileParser,
)
where
import Control.Monad
import Control.Monad.Except (ExceptT (..), liftEither)
import Crypto.Secp256k1
import Data.Aeson (eitherDecodeFileStrict)
import Data.Aeson.Encoding
import Data.Aeson.Types
import Data.Base16.Types
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Base16
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.Lazy.Base16 qualified as LB16
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.Serialize qualified as S
import Data.Text (Text)
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
import Data.Word
import Test.Hspec
bsToInteger :: ByteString -> Integer
bsToInteger :: ByteString -> Integer
bsToInteger = (Word8 -> Integer -> Integer) -> Integer -> ByteString -> Integer
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.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
B.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
integerToBS :: Integer -> ByteString
integerToBS :: Integer -> ByteString
integerToBS Integer
0 = [Word8] -> ByteString
B.pack [Word8
0]
integerToBS Integer
i
| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 = ByteString -> ByteString
B.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
B.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)
hexEncoding :: LB.ByteString -> Encoding
hexEncoding :: ByteString -> Encoding
hexEncoding ByteString
b =
Builder -> Encoding
forall a. Builder -> Encoding' a
unsafeToEncoding (Builder -> Encoding) -> Builder -> Encoding
forall a b. (a -> b) -> a -> b
$
Char -> Builder
char7 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hexBuilder ByteString
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'"'
hexBuilder :: LB.ByteString -> Builder
hexBuilder :: ByteString -> Builder
hexBuilder = ByteString -> Builder
lazyByteStringHex
encodeHex :: ByteString -> Text
encodeHex :: ByteString -> Text
encodeHex = Base16 Text -> Text
forall a. Base16 a -> a
extractBase16 (Base16 Text -> Text)
-> (ByteString -> Base16 Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 Text
encodeBase16
encodeHexLazy :: LB.ByteString -> LT.Text
encodeHexLazy :: ByteString -> Text
encodeHexLazy = Base16 Text -> Text
forall a. Base16 a -> a
extractBase16 (Base16 Text -> Text)
-> (ByteString -> Base16 Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 Text
LB16.encodeBase16
decodeHex :: Text -> Maybe ByteString
decodeHex :: Text -> Maybe ByteString
decodeHex Text
t =
if ByteString -> Bool
isBase16 ByteString
u8
then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Base16 ByteString -> ByteString)
-> Base16 ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base16 ByteString -> ByteString
decodeBase16 (Base16 ByteString -> Maybe ByteString)
-> Base16 ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Base16 ByteString
forall a. a -> Base16 a
assertBase16 ByteString
u8
else Maybe ByteString
forall a. Maybe a
Nothing
where
u8 :: ByteString
u8 = Text -> ByteString
T.encodeUtf8 Text
t
decodeHexLazy :: LT.Text -> Maybe LB.ByteString
decodeHexLazy :: Text -> Maybe ByteString
decodeHexLazy Text
t =
if ByteString -> Bool
LB16.isBase16 ByteString
u8
then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Base16 ByteString -> ByteString)
-> Base16 ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base16 ByteString -> ByteString
LB16.decodeBase16 (Base16 ByteString -> Maybe ByteString)
-> Base16 ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Base16 ByteString
forall a. a -> Base16 a
assertBase16 ByteString
u8
else Maybe ByteString
forall a. Maybe a
Nothing
where
u8 :: ByteString
u8 = Text -> ByteString
LT.encodeUtf8 Text
t
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
B.take Int
q ByteString
bs
| Bool
otherwise = ByteString
i ByteString -> Word8 -> ByteString
`B.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
B.take (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs
i :: ByteString
i = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.init ByteString
s
l :: Word8
l = HasCallStack => ByteString -> Word8
ByteString -> Word8
B.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))
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: forall a b. 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
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: forall b a. 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
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 = 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
updateIndex ::
Int ->
[a] ->
(a -> a) ->
[a]
updateIndex :: forall a. 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 a. [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
matchTemplate ::
[a] ->
[b] ->
(a -> b -> Bool) ->
[Maybe a]
matchTemplate :: forall a b. [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 a. [a] -> 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
fst3 :: (a, b, c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a
snd3 :: (a, b, c) -> b
snd3 :: forall a b c. (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b
lst3 :: (a, b, c) -> c
lst3 :: forall a b c. (a, b, c) -> c
lst3 (a
_, b
_, c
c) = c
c
dropFieldLabel :: Int -> Options
dropFieldLabel :: Int -> Options
dropFieldLabel Int
n =
Options
defaultOptions
{ fieldLabelModifier = map toLower . drop n
}
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels :: Int -> Int -> [Char] -> Options
dropSumLabels Int
c Int
f [Char]
tag =
(Int -> Options
dropFieldLabel Int
f)
{ constructorTagModifier = map toLower . drop c,
sumEncoding = defaultTaggedObject {tagFieldName = tag}
}
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 b a. (b -> a -> b) -> b -> [a] -> b
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)
putInt32be :: (MonadPut m) => Int32 -> m ()
putInt32be :: forall (m :: * -> *). MonadPut m => 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 :: forall (m :: * -> *). MonadGet m => 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 a. a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *). MonadPut m => 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 :: forall (m :: * -> *). MonadGet m => 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 a. a -> m a
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 a. a -> m a
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 :: forall (m :: * -> *). MonadPut m => 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 :: forall (m :: * -> *). MonadGet m => m Integer
getInteger =
m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8 m Word8 -> (Word8 -> m Integer) -> m Integer
forall a b. m a -> (a -> m b) -> m b
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 a. a -> m a
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 :: forall (m :: * -> *) a.
MonadPut m =>
(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 a b. m a -> m b -> m b
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 =
m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8 m Word8 -> (Word8 -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Word8
0x00 -> Maybe a -> m (Maybe a)
forall a. a -> m 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 a. [Char] -> m a
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
Word64 -> m ()
forall (m :: * -> *). MonadPut m => Word64 -> m ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs))
ByteString -> m ()
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 <- 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
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll :: forall a. (Integral a, Bits a) => 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 :: forall a. (Integral a, Bits a) => [Word8] -> a
roll = (Word8 -> a -> a) -> a -> [Word8] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall a. (Ord a, Integral a) => 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
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 = [(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 :: forall (m :: * -> *) a.
MonadPut m =>
(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 :: 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 m () -> m () -> m ()
forall a b. m a -> m b -> m b
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 = (,) (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 a b. m (a -> b) -> m a -> m 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 :: forall (m :: * -> *) a. MonadPut m => (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 a. [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 :: forall (m :: * -> *) a. MonadGet m => 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
prepareContext :: (Ctx -> SpecWith a) -> SpecWith a
prepareContext :: forall a. (Ctx -> SpecWith a) -> SpecWith a
prepareContext Ctx -> SpecWith a
go = do
Ctx
ctx <- IO Ctx -> SpecM a Ctx
forall r a. IO r -> SpecM a r
runIO (IO Ctx -> SpecM a Ctx) -> IO Ctx -> SpecM a Ctx
forall a b. (a -> b) -> a -> b
$ do
Ctx
ctx <- IO Ctx
createContext
Ctx -> IO ()
randomizeContext Ctx
ctx
Ctx -> IO Ctx
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ctx
ctx
IO () -> SpecWith a -> SpecWith a
forall a. HasCallStack => IO () -> SpecWith a -> SpecWith a
afterAll_ (Ctx -> IO ()
destroyContext Ctx
ctx) (Ctx -> SpecWith a
go Ctx
ctx)
customCerealID :: (Eq a) => S.Get a -> S.Putter a -> a -> Bool
customCerealID :: forall a. Eq a => Get a -> Putter a -> a -> Bool
customCerealID Get a
g Putter a
p a
a = (Get a -> ByteString -> Either [Char] a
forall a. Get a -> ByteString -> Either [Char] a
S.runGet Get a
g (ByteString -> Either [Char] a)
-> (a -> ByteString) -> a -> Either [Char] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
S.runPut (Put -> ByteString) -> Putter a -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Putter a
p) a
a Either [Char] a -> Either [Char] a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Either [Char] a
forall a b. b -> Either a b
Right a
a
readTestFile :: (FromJSON a) => FilePath -> IO a
readTestFile :: forall a. FromJSON a => [Char] -> IO a
readTestFile [Char]
fp =
[Char] -> IO (Either [Char] a)
forall a. FromJSON a => [Char] -> IO (Either [Char] a)
eitherDecodeFileStrict ([Char]
"data/" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fp) IO (Either [Char] a) -> (Either [Char] a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> IO a) -> (a -> IO a) -> Either [Char] a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO a) -> ([Char] -> [Char]) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
message) a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
where
message :: [Char] -> [Char]
message [Char]
aesonErr = [Char]
"Could not read test file " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
aesonErr
readTestFileParser :: (Value -> Parser a) -> FilePath -> IO a
readTestFileParser :: forall a. (Value -> Parser a) -> [Char] -> IO a
readTestFileParser Value -> Parser a
p [Char]
fp = do
Value
v <- [Char] -> IO Value
forall a. FromJSON a => [Char] -> IO a
readTestFile [Char]
fp
case (Value -> Parser a) -> Value -> Result a
forall a b. (a -> Parser b) -> a -> Result b
parse Value -> Parser a
p Value
v of
Error [Char]
s -> [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
s
Success a
x -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x