{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Haskoin.Util
(
bsToInteger
, integerToBS
, hexBuilder
, encodeHex
, decodeHex
, getBits
, eitherToMaybe
, maybeToEither
, liftEither
, liftMaybe
, updateIndex
, matchTemplate
, convertBits
, fst3
, snd3
, lst3
, dropFieldLabel
, dropSumLabels
) where
import Control.Monad (guard)
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 Data.Char (toLower)
import Data.List
import Data.Text (Text)
import qualified Data.Text.Encoding as E
import Data.Word (Word8)
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
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 :: ByteString -> Builder
hexBuilder :: ByteString -> Builder
hexBuilder = ByteString -> Builder
byteStringHex
encodeHex :: ByteString -> Text
encodeHex :: ByteString -> Text
encodeHex = ByteString -> Text
E.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteStringHex
decodeHex :: Text -> Maybe ByteString
# if MIN_VERSION_base16_bytestring(1,0,0)
decodeHex :: Text -> Maybe ByteString
decodeHex = Either [Char] ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either [Char] ByteString -> Maybe ByteString)
-> (Text -> Either [Char] ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
B16.decode (ByteString -> Either [Char] ByteString)
-> (Text -> ByteString) -> Text -> Either [Char] ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8
# else
decodeHex text =
let (x, b) = B16.decode (E.encodeUtf8 text)
in guard (b == BS.empty) >> return x
# endif
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))
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
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
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
updateIndex :: Int
-> [a]
-> (a -> a)
-> [a]
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
matchTemplate :: [a]
-> [b]
-> (a -> b -> Bool)
-> [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
fst3 :: (a,b,c) -> a
fst3 :: (a, b, c) -> a
fst3 (a :: a
a,_,_) = a
a
snd3 :: (a,b,c) -> b
snd3 :: (a, b, c) -> b
snd3 (_,b :: b
b,_) = b
b
lst3 :: (a,b,c) -> c
lst3 :: (a, b, c) -> c
lst3 (_,_,c :: c
c) = c
c
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
}
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 }
}
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)