{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Cardano.Ledger.Binary.Decoding.Annotated (
Annotated (..),
decodeAnnotated,
ByteSpan (..),
Decoded (..),
annotationBytes,
annotatedDecoder,
slice,
decCBORAnnotated,
reAnnotate,
Annotator (..),
annotatorSlice,
withSlice,
FullByteString (..),
decodeAnnSet,
) where
import Cardano.Ledger.Binary.Decoding.DecCBOR (DecCBOR (..))
import Cardano.Ledger.Binary.Decoding.Decoder (
Decoder,
allowTag,
decodeList,
decodeWithByteSpan,
getOriginalBytes,
setTag,
whenDecoderVersionAtLeast,
)
import Cardano.Ledger.Binary.Encoding (EncCBOR, Version, serialize')
import Cardano.Ledger.Binary.Version (natVersion)
import Codec.CBOR.Read (ByteOffset)
import Control.DeepSeq (NFData)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Bifunctor (Bifunctor (first, second))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Function (on)
import Data.Functor ((<&>))
import Data.Kind (Type)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
slice :: BSL.ByteString -> ByteSpan -> BSL.ByteString
slice :: ByteString -> ByteSpan -> ByteString
slice ByteString
bytes (ByteSpan Int64
start Int64
end) =
Int64 -> ByteString -> ByteString
BSL.take (Int64
end Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
start) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.drop Int64
start ByteString
bytes
{-# INLINE slice #-}
data ByteSpan = ByteSpan !ByteOffset !ByteOffset
deriving ((forall x. ByteSpan -> Rep ByteSpan x)
-> (forall x. Rep ByteSpan x -> ByteSpan) -> Generic ByteSpan
forall x. Rep ByteSpan x -> ByteSpan
forall x. ByteSpan -> Rep ByteSpan x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ByteSpan -> Rep ByteSpan x
from :: forall x. ByteSpan -> Rep ByteSpan x
$cto :: forall x. Rep ByteSpan x -> ByteSpan
to :: forall x. Rep ByteSpan x -> ByteSpan
Generic, Int -> ByteSpan -> ShowS
[ByteSpan] -> ShowS
ByteSpan -> String
(Int -> ByteSpan -> ShowS)
-> (ByteSpan -> String) -> ([ByteSpan] -> ShowS) -> Show ByteSpan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByteSpan -> ShowS
showsPrec :: Int -> ByteSpan -> ShowS
$cshow :: ByteSpan -> String
show :: ByteSpan -> String
$cshowList :: [ByteSpan] -> ShowS
showList :: [ByteSpan] -> ShowS
Show)
instance ToJSON ByteSpan
data Annotated b a = Annotated {forall b a. Annotated b a -> b
unAnnotated :: !b, forall b a. Annotated b a -> a
annotation :: !a}
deriving (Annotated b a -> Annotated b a -> Bool
(Annotated b a -> Annotated b a -> Bool)
-> (Annotated b a -> Annotated b a -> Bool) -> Eq (Annotated b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall b a. (Eq b, Eq a) => Annotated b a -> Annotated b a -> Bool
$c== :: forall b a. (Eq b, Eq a) => Annotated b a -> Annotated b a -> Bool
== :: Annotated b a -> Annotated b a -> Bool
$c/= :: forall b a. (Eq b, Eq a) => Annotated b a -> Annotated b a -> Bool
/= :: Annotated b a -> Annotated b a -> Bool
Eq, Int -> Annotated b a -> ShowS
[Annotated b a] -> ShowS
Annotated b a -> String
(Int -> Annotated b a -> ShowS)
-> (Annotated b a -> String)
-> ([Annotated b a] -> ShowS)
-> Show (Annotated b a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall b a. (Show b, Show a) => Int -> Annotated b a -> ShowS
forall b a. (Show b, Show a) => [Annotated b a] -> ShowS
forall b a. (Show b, Show a) => Annotated b a -> String
$cshowsPrec :: forall b a. (Show b, Show a) => Int -> Annotated b a -> ShowS
showsPrec :: Int -> Annotated b a -> ShowS
$cshow :: forall b a. (Show b, Show a) => Annotated b a -> String
show :: Annotated b a -> String
$cshowList :: forall b a. (Show b, Show a) => [Annotated b a] -> ShowS
showList :: [Annotated b a] -> ShowS
Show, (forall a b. (a -> b) -> Annotated b a -> Annotated b b)
-> (forall a b. a -> Annotated b b -> Annotated b a)
-> Functor (Annotated b)
forall a b. a -> Annotated b b -> Annotated b a
forall a b. (a -> b) -> Annotated b a -> Annotated b b
forall b a b. a -> Annotated b b -> Annotated b a
forall b a b. (a -> b) -> Annotated b a -> Annotated b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall b a b. (a -> b) -> Annotated b a -> Annotated b b
fmap :: forall a b. (a -> b) -> Annotated b a -> Annotated b b
$c<$ :: forall b a b. a -> Annotated b b -> Annotated b a
<$ :: forall a b. a -> Annotated b b -> Annotated b a
Functor, (forall x. Annotated b a -> Rep (Annotated b a) x)
-> (forall x. Rep (Annotated b a) x -> Annotated b a)
-> Generic (Annotated b a)
forall x. Rep (Annotated b a) x -> Annotated b a
forall x. Annotated b a -> Rep (Annotated b a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b a x. Rep (Annotated b a) x -> Annotated b a
forall b a x. Annotated b a -> Rep (Annotated b a) x
$cfrom :: forall b a x. Annotated b a -> Rep (Annotated b a) x
from :: forall x. Annotated b a -> Rep (Annotated b a) x
$cto :: forall b a x. Rep (Annotated b a) x -> Annotated b a
to :: forall x. Rep (Annotated b a) x -> Annotated b a
Generic)
deriving anyclass (Annotated b a -> ()
(Annotated b a -> ()) -> NFData (Annotated b a)
forall a. (a -> ()) -> NFData a
forall b a. (NFData b, NFData a) => Annotated b a -> ()
$crnf :: forall b a. (NFData b, NFData a) => Annotated b a -> ()
rnf :: Annotated b a -> ()
NFData, Context -> Annotated b a -> IO (Maybe ThunkInfo)
Proxy (Annotated b a) -> String
(Context -> Annotated b a -> IO (Maybe ThunkInfo))
-> (Context -> Annotated b a -> IO (Maybe ThunkInfo))
-> (Proxy (Annotated b a) -> String)
-> NoThunks (Annotated b a)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall b a.
(NoThunks b, NoThunks a) =>
Context -> Annotated b a -> IO (Maybe ThunkInfo)
forall b a.
(NoThunks b, NoThunks a) =>
Proxy (Annotated b a) -> String
$cnoThunks :: forall b a.
(NoThunks b, NoThunks a) =>
Context -> Annotated b a -> IO (Maybe ThunkInfo)
noThunks :: Context -> Annotated b a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall b a.
(NoThunks b, NoThunks a) =>
Context -> Annotated b a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Annotated b a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall b a.
(NoThunks b, NoThunks a) =>
Proxy (Annotated b a) -> String
showTypeOf :: Proxy (Annotated b a) -> String
NoThunks)
instance Bifunctor Annotated where
first :: forall a b c. (a -> b) -> Annotated a c -> Annotated b c
first a -> b
f (Annotated a
b c
a) = b -> c -> Annotated b c
forall b a. b -> a -> Annotated b a
Annotated (a -> b
f a
b) c
a
second :: forall b c a. (b -> c) -> Annotated a b -> Annotated a c
second = (b -> c) -> Annotated a b -> Annotated a c
forall a b. (a -> b) -> Annotated a a -> Annotated a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
instance (Eq a, Ord b) => Ord (Annotated b a) where
compare :: Annotated b a -> Annotated b a -> Ordering
compare = b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering)
-> (Annotated b a -> b)
-> Annotated b a
-> Annotated b a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Annotated b a -> b
forall b a. Annotated b a -> b
unAnnotated
instance ToJSON b => ToJSON (Annotated b a) where
toJSON :: Annotated b a -> Value
toJSON = b -> Value
forall a. ToJSON a => a -> Value
toJSON (b -> Value) -> (Annotated b a -> b) -> Annotated b a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated b a -> b
forall b a. Annotated b a -> b
unAnnotated
toEncoding :: Annotated b a -> Encoding
toEncoding = b -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (b -> Encoding)
-> (Annotated b a -> b) -> Annotated b a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated b a -> b
forall b a. Annotated b a -> b
unAnnotated
instance FromJSON b => FromJSON (Annotated b ()) where
parseJSON :: Value -> Parser (Annotated b ())
parseJSON Value
j = (b -> () -> Annotated b ()) -> () -> b -> Annotated b ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> () -> Annotated b ()
forall b a. b -> a -> Annotated b a
Annotated () (b -> Annotated b ()) -> Parser b -> Parser (Annotated b ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
j
instance DecCBOR a => DecCBOR (Annotated a BSL.ByteString) where
decCBOR :: forall s. Decoder s (Annotated a ByteString)
decCBOR = Decoder s a -> Decoder s (Annotated a ByteString)
forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s a
forall s. Decoder s a
forall a s. DecCBOR a => Decoder s a
decCBOR
annotatedDecoder :: Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder :: forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
vd =
Decoder s a -> Decoder s (a, Int64, Int64)
forall s a. Decoder s a -> Decoder s (a, Int64, Int64)
decodeWithByteSpan Decoder s a
vd Decoder s (a, Int64, Int64)
-> ((a, Int64, Int64) -> Annotated a ByteSpan)
-> Decoder s (Annotated a ByteSpan)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
x, Int64
start, Int64
end) -> a -> ByteSpan -> Annotated a ByteSpan
forall b a. b -> a -> Annotated b a
Annotated a
x (Int64 -> Int64 -> ByteSpan
ByteSpan Int64
start Int64
end)
{-# INLINE annotatedDecoder #-}
decCBORAnnotated :: DecCBOR a => Decoder s (Annotated a ByteSpan)
decCBORAnnotated :: forall a s. DecCBOR a => Decoder s (Annotated a ByteSpan)
decCBORAnnotated = Decoder s a -> Decoder s (Annotated a ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
forall s. Decoder s a
forall a s. DecCBOR a => Decoder s a
decCBOR
{-# INLINE decCBORAnnotated #-}
annotationBytes :: Functor f => BSL.ByteString -> f ByteSpan -> f BS.ByteString
annotationBytes :: forall (f :: * -> *).
Functor f =>
ByteString -> f ByteSpan -> f ByteString
annotationBytes ByteString
bytes = (ByteSpan -> ByteString) -> f ByteSpan -> f ByteString
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteSpan -> ByteString
slice ByteString
bytes)
reAnnotate :: EncCBOR a => Version -> Annotated a b -> Annotated a BS.ByteString
reAnnotate :: forall a b.
EncCBOR a =>
Version -> Annotated a b -> Annotated a ByteString
reAnnotate Version
version (Annotated a
x b
_) = a -> ByteString -> Annotated a ByteString
forall b a. b -> a -> Annotated b a
Annotated a
x (Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
version a
x)
decodeAnnotated :: Decoder s a -> Decoder s (Annotated a BSL.ByteString)
decodeAnnotated :: forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s a
decoder = do
ByteString
bsl <- Decoder s ByteString
forall s. Decoder s ByteString
getOriginalBytes
(ByteSpan -> ByteString)
-> Annotated a ByteSpan -> Annotated a ByteString
forall a b. (a -> b) -> Annotated a a -> Annotated a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteSpan -> ByteString
slice ByteString
bsl) (Annotated a ByteSpan -> Annotated a ByteString)
-> Decoder s (Annotated a ByteSpan)
-> Decoder s (Annotated a ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s (Annotated a ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
decoder
{-# INLINE decodeAnnotated #-}
class Decoded t where
type BaseType t :: Type
recoverBytes :: t -> BS.ByteString
instance Decoded (Annotated b BS.ByteString) where
type BaseType (Annotated b BS.ByteString) = b
recoverBytes :: Annotated b ByteString -> ByteString
recoverBytes = Annotated b ByteString -> ByteString
forall b a. Annotated b a -> a
annotation
newtype FullByteString = Full BSL.ByteString
newtype Annotator a = Annotator {forall a. Annotator a -> FullByteString -> a
runAnnotator :: FullByteString -> a}
deriving newtype (Applicative Annotator
Applicative Annotator =>
(forall a b. Annotator a -> (a -> Annotator b) -> Annotator b)
-> (forall a b. Annotator a -> Annotator b -> Annotator b)
-> (forall a. a -> Annotator a)
-> Monad Annotator
forall a. a -> Annotator a
forall a b. Annotator a -> Annotator b -> Annotator b
forall a b. Annotator a -> (a -> Annotator b) -> Annotator b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Annotator a -> (a -> Annotator b) -> Annotator b
>>= :: forall a b. Annotator a -> (a -> Annotator b) -> Annotator b
$c>> :: forall a b. Annotator a -> Annotator b -> Annotator b
>> :: forall a b. Annotator a -> Annotator b -> Annotator b
$creturn :: forall a. a -> Annotator a
return :: forall a. a -> Annotator a
Monad, Functor Annotator
Functor Annotator =>
(forall a. a -> Annotator a)
-> (forall a b. Annotator (a -> b) -> Annotator a -> Annotator b)
-> (forall a b c.
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c)
-> (forall a b. Annotator a -> Annotator b -> Annotator b)
-> (forall a b. Annotator a -> Annotator b -> Annotator a)
-> Applicative Annotator
forall a. a -> Annotator a
forall a b. Annotator a -> Annotator b -> Annotator a
forall a b. Annotator a -> Annotator b -> Annotator b
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall a b c.
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Annotator a
pure :: forall a. a -> Annotator a
$c<*> :: forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
<*> :: forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
liftA2 :: forall a b c.
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
$c*> :: forall a b. Annotator a -> Annotator b -> Annotator b
*> :: forall a b. Annotator a -> Annotator b -> Annotator b
$c<* :: forall a b. Annotator a -> Annotator b -> Annotator a
<* :: forall a b. Annotator a -> Annotator b -> Annotator a
Applicative, (forall a b. (a -> b) -> Annotator a -> Annotator b)
-> (forall a b. a -> Annotator b -> Annotator a)
-> Functor Annotator
forall a b. a -> Annotator b -> Annotator a
forall a b. (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Annotator a -> Annotator b
fmap :: forall a b. (a -> b) -> Annotator a -> Annotator b
$c<$ :: forall a b. a -> Annotator b -> Annotator a
<$ :: forall a b. a -> Annotator b -> Annotator a
Functor)
annotatorSlice ::
Decoder s (Annotator (BSL.ByteString -> a)) ->
Decoder s (Annotator a)
annotatorSlice :: forall s a.
Decoder s (Annotator (ByteString -> a)) -> Decoder s (Annotator a)
annotatorSlice Decoder s (Annotator (ByteString -> a))
dec = do
(Annotator (ByteString -> a)
k, Annotator ByteString
bytes) <- Decoder s (Annotator (ByteString -> a))
-> Decoder s (Annotator (ByteString -> a), Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s (Annotator (ByteString -> a))
dec
Annotator a -> Decoder s (Annotator a)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator a -> Decoder s (Annotator a))
-> Annotator a -> Decoder s (Annotator a)
forall a b. (a -> b) -> a -> b
$ Annotator (ByteString -> a)
k Annotator (ByteString -> a) -> Annotator ByteString -> Annotator a
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
bytes
{-# INLINE annotatorSlice #-}
withSlice :: Decoder s a -> Decoder s (a, Annotator BSL.ByteString)
withSlice :: forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s a
dec = do
Annotated a
r ByteSpan
byteSpan <- Decoder s a -> Decoder s (Annotated a ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
dec
(a, Annotator ByteString) -> Decoder s (a, Annotator ByteString)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, (FullByteString -> ByteString) -> Annotator ByteString
forall a. (FullByteString -> a) -> Annotator a
Annotator (\(Full ByteString
bsl) -> ByteString -> ByteSpan -> ByteString
slice ByteString
bsl ByteSpan
byteSpan))
{-# INLINE withSlice #-}
decodeAnnSet :: Ord t => Decoder s (Annotator t) -> Decoder s (Annotator (Set.Set t))
decodeAnnSet :: forall t s.
Ord t =>
Decoder s (Annotator t) -> Decoder s (Annotator (Set t))
decodeAnnSet Decoder s (Annotator t)
dec = do
Version -> Decoder s () -> Decoder s ()
forall s a. Version -> Decoder s a -> Decoder s ()
whenDecoderVersionAtLeast (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
Word -> Decoder s ()
forall s. Word -> Decoder s ()
allowTag Word
setTag
[Annotator t]
xs <- Decoder s (Annotator t) -> Decoder s [Annotator t]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (Annotator t)
dec
Annotator (Set t) -> Decoder s (Annotator (Set t))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([t] -> Set t
forall a. Ord a => [a] -> Set a
Set.fromList ([t] -> Set t) -> Annotator [t] -> Annotator (Set t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Annotator t] -> Annotator [t]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Annotator t]
xs)
{-# INLINE decodeAnnSet #-}