{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PlutusCore.Flat.Bits (
Bits,
toBools,
fromBools,
bits,
paddedBits,
asBytes,
asBits,
takeBits,
takeAllBits,
) where
import Data.Bits (FiniteBits (finiteBitSize), testBit)
import Data.ByteString qualified as B
import Data.Vector.Unboxed qualified as V
import Data.Word (Word8)
import PlutusCore.Flat.Class (Flat)
import PlutusCore.Flat.Decoder (Decoded)
import PlutusCore.Flat.Filler (PostAligned (PostAligned), fillerLength)
import PlutusCore.Flat.Run (flat, unflatRaw)
import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), hsep, text)
type Bits = V.Vector Bool
toBools :: Bits -> [Bool]
toBools :: Bits -> [Bool]
toBools = Bits -> [Bool]
forall a. Unbox a => Vector a -> [a]
V.toList
fromBools :: [Bool] -> Bits
fromBools :: [Bool] -> Bits
fromBools = [Bool] -> Bits
forall a. Unbox a => [a] -> Vector a
V.fromList
bits :: forall a. Flat a => a -> Bits
bits :: forall a. Flat a => a -> Bits
bits a
v =
let lbs :: ByteString
lbs = a -> ByteString
forall a. Flat a => a -> ByteString
flat a
v
in case ByteString -> Decoded (PostAligned a)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflatRaw ByteString
lbs :: Decoded (PostAligned a) of
Right (PostAligned a
_ Filler
f) -> Int -> ByteString -> Bits
takeBits (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
B.length ByteString
lbs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Filler -> Int
forall a. Num a => Filler -> a
fillerLength Filler
f) ByteString
lbs
Left DecodeException
_ -> [Char] -> Bits
forall a. HasCallStack => [Char] -> a
error [Char]
"incorrect coding or decoding, please inform the maintainer of this package"
paddedBits :: forall a. Flat a => a -> Bits
paddedBits :: forall a. Flat a => a -> Bits
paddedBits a
v = let lbs :: ByteString
lbs = a -> ByteString
forall a. Flat a => a -> ByteString
flat a
v in ByteString -> Bits
takeAllBits ByteString
lbs
takeAllBits :: B.ByteString -> Bits
takeAllBits :: ByteString -> Bits
takeAllBits ByteString
lbs= Int -> ByteString -> Bits
takeBits (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
B.length ByteString
lbs) ByteString
lbs
takeBits :: Int -> B.ByteString -> Bits
takeBits :: Int -> ByteString -> Bits
takeBits Int
numBits ByteString
lbs =
Int -> (Int -> Bool) -> Bits
forall a. Unbox a => Int -> (Int -> a) -> Vector a
V.generate
(Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numBits)
( \Int
n ->
let (Int
bb, Int
b) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
8
in Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
lbs (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bb)) (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b)
)
asBits :: FiniteBits a => a -> Bits
asBits :: forall a. FiniteBits a => a -> Bits
asBits a
w = let s :: Int
s = a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize a
w in Int -> (Int -> Bool) -> Bits
forall a. Unbox a => Int -> (Int -> a) -> Vector a
V.generate Int
s (a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
w (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
-))
asBytes :: Bits -> [Word8]
asBytes :: Bits -> [Word8]
asBytes = ([Bool] -> Word8) -> [[Bool]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map [Bool] -> Word8
byteVal ([[Bool]] -> [Word8]) -> (Bits -> [[Bool]]) -> Bits -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [[Bool]]
forall t. [t] -> [[t]]
bytes ([Bool] -> [[Bool]]) -> (Bits -> [Bool]) -> Bits -> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bits -> [Bool]
forall a. Unbox a => Vector a -> [a]
V.toList
byteVal :: [Bool] -> Word8
byteVal :: [Bool] -> Word8
byteVal = [Word8] -> Word8
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word8] -> Word8) -> ([Bool] -> [Word8]) -> [Bool] -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool -> Word8) -> [Word8] -> [Bool] -> [Word8]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Word8
e Bool
b -> (if Bool
b then Word8
e else Word8
0)) ([Word8
2 Word8 -> Int -> Word8
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n | Int
n <- [Int
7 :: Int, Int
6 .. Int
0]])
bytes :: [t] -> [[t]]
bytes :: forall t. [t] -> [[t]]
bytes [] = []
bytes [t]
l = let ([t]
w, [t]
r) = Int -> [t] -> ([t], [t])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [t]
l in [t]
w [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [t] -> [[t]]
forall t. [t] -> [[t]]
bytes [t]
r
instance Pretty Bits where
pPrint :: Bits -> Doc
pPrint = [Doc] -> Doc
hsep ([Doc] -> Doc) -> (Bits -> [Doc]) -> Bits -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> Doc) -> [[Bool]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Bool] -> Doc
forall (t :: * -> *). Foldable t => t Bool -> Doc
prettyBits ([[Bool]] -> [Doc]) -> (Bits -> [[Bool]]) -> Bits -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [[Bool]]
forall t. [t] -> [[t]]
bytes ([Bool] -> [[Bool]]) -> (Bits -> [Bool]) -> Bits -> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bits -> [Bool]
forall a. Unbox a => Vector a -> [a]
V.toList
prettyBits :: Foldable t => t Bool -> Doc
prettyBits :: forall (t :: * -> *). Foldable t => t Bool -> Doc
prettyBits t Bool
l =
[Char] -> Doc
text ([Char] -> Doc) -> (t Bool -> [Char]) -> t Bool -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (t Bool -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Bool
l) ([Char] -> [Char]) -> (t Bool -> [Char]) -> t Bool -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> [Char]) -> t Bool -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Bool
b -> if Bool
b then [Char]
"1" else [Char]
"0") (t Bool -> Doc) -> t Bool -> Doc
forall a b. (a -> b) -> a -> b
$ t Bool
l