{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
{-# LANGUAGE Rank2Types         #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Binary.Annotated
  ( Annotated(..)
  , ByteSpan(..)
  , Decoded(..)
  , annotationBytes
  , annotatedDecoder
  , slice
  , fromCBORAnnotated
  , decodeFullAnnotatedBytes
  , reAnnotate
  , Annotator (..)
  , annotatorSlice
  , decodeAnnotator
  , withSlice
  , FullByteString (..)
  )
where

import Cardano.Prelude

import Codec.CBOR.Read (ByteOffset)
import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.ByteString.Lazy as BSL
import NoThunks.Class (NoThunks)

import Cardano.Binary.Deserialize (decodeFullDecoder)
import Cardano.Binary.FromCBOR
  (Decoder, DecoderError, FromCBOR(..), decodeWithByteSpan)
import Cardano.Binary.ToCBOR
  (ToCBOR)
import Cardano.Binary.Serialize (serialize')



-- | Extract a substring of a given ByteString corresponding to the offsets.
slice :: BSL.ByteString -> ByteSpan -> LByteString
slice :: ByteString -> ByteSpan -> ByteString
slice ByteString
bytes (ByteSpan ByteOffset
start ByteOffset
end) =
  ByteOffset -> ByteString -> ByteString
BSL.take (ByteOffset
end ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
- ByteOffset
start) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteOffset -> ByteString -> ByteString
BSL.drop ByteOffset
start ByteString
bytes

-- | A pair of offsets delimiting the beginning and end of a substring of a ByteString
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
$cto :: forall x. Rep ByteSpan x -> ByteSpan
$cfrom :: forall x. ByteSpan -> Rep ByteSpan x
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
showList :: [ByteSpan] -> ShowS
$cshowList :: [ByteSpan] -> ShowS
show :: ByteSpan -> String
$cshow :: ByteSpan -> String
showsPrec :: Int -> ByteSpan -> ShowS
$cshowsPrec :: Int -> ByteSpan -> ShowS
Show)

-- Used for debugging purposes only.
instance ToJSON ByteSpan where

data Annotated b a = Annotated { Annotated b a -> b
unAnnotated :: !b, 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
/= :: 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
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
showList :: [Annotated b a] -> ShowS
$cshowList :: forall b a. (Show b, Show a) => [Annotated b a] -> ShowS
show :: Annotated b a -> String
$cshow :: forall b a. (Show b, Show a) => Annotated b a -> String
showsPrec :: Int -> Annotated b a -> ShowS
$cshowsPrec :: forall b a. (Show b, Show a) => Int -> Annotated b a -> ShowS
Show, a -> Annotated b b -> Annotated b a
(a -> b) -> Annotated b a -> Annotated b b
(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
<$ :: a -> Annotated b b -> Annotated b a
$c<$ :: forall b a b. a -> Annotated b b -> Annotated b a
fmap :: (a -> b) -> Annotated b a -> Annotated b b
$cfmap :: forall b a b. (a -> b) -> Annotated b a -> Annotated b b
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
$cto :: forall b a x. Rep (Annotated b a) x -> Annotated b a
$cfrom :: forall b a x. Annotated b a -> Rep (Annotated b a) x
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 -> ()
rnf :: Annotated b a -> ()
$crnf :: forall b a. (NFData b, NFData a) => 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
showTypeOf :: Proxy (Annotated b a) -> String
$cshowTypeOf :: forall b a.
(NoThunks b, NoThunks a) =>
Proxy (Annotated b a) -> String
wNoThunks :: Context -> Annotated b a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall b a.
(NoThunks b, NoThunks a) =>
Context -> Annotated b a -> IO (Maybe ThunkInfo)
noThunks :: Context -> Annotated b a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall b a.
(NoThunks b, NoThunks a) =>
Context -> Annotated b a -> IO (Maybe ThunkInfo)
NoThunks)

instance Bifunctor Annotated where
  first :: (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 :: (b -> c) -> Annotated a b -> Annotated a c
second = (b -> c) -> Annotated a b -> Annotated a c
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 k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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

-- | A decoder for a value paired with an annotation specifying the start and end
-- of the consumed bytes.
annotatedDecoder :: Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder :: Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
d = Decoder s a -> Decoder s (a, ByteOffset, ByteOffset)
forall s a. Decoder s a -> Decoder s (a, ByteOffset, ByteOffset)
decodeWithByteSpan Decoder s a
d
  Decoder s (a, ByteOffset, ByteOffset)
-> ((a, ByteOffset, ByteOffset) -> Annotated a ByteSpan)
-> Decoder s (Annotated a ByteSpan)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
x, ByteOffset
start, ByteOffset
end) -> a -> ByteSpan -> Annotated a ByteSpan
forall b a. b -> a -> Annotated b a
Annotated a
x (ByteOffset -> ByteOffset -> ByteSpan
ByteSpan ByteOffset
start ByteOffset
end)

-- | A decoder for a value paired with an annotation specifying the start and end
-- of the consumed bytes.
fromCBORAnnotated :: FromCBOR a => Decoder s (Annotated a ByteSpan)
fromCBORAnnotated :: Decoder s (Annotated a ByteSpan)
fromCBORAnnotated = Decoder s a -> Decoder s (Annotated a ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

annotationBytes :: Functor f => LByteString -> f ByteSpan -> f ByteString
annotationBytes :: ByteString -> f ByteSpan -> f ByteString
annotationBytes ByteString
bytes = (ByteSpan -> ByteString) -> f ByteSpan -> f ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
slice ByteString
bytes)

-- | Decodes a value from a ByteString, requiring that the full ByteString is consumed, and
-- replaces ByteSpan annotations with the corresponding substrings of the input string.
decodeFullAnnotatedBytes
  :: Functor f
  => Text
  -> (forall s . Decoder s (f ByteSpan))
  -> LByteString
  -> Either DecoderError (f ByteString)
decodeFullAnnotatedBytes :: Text
-> (forall s. Decoder s (f ByteSpan))
-> ByteString
-> Either DecoderError (f ByteString)
decodeFullAnnotatedBytes Text
lbl forall s. Decoder s (f ByteSpan)
decoder ByteString
bytes =
  ByteString -> f ByteSpan -> f ByteString
forall (f :: * -> *).
Functor f =>
ByteString -> f ByteSpan -> f ByteString
annotationBytes ByteString
bytes (f ByteSpan -> f ByteString)
-> Either DecoderError (f ByteSpan)
-> Either DecoderError (f ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (forall s. Decoder s (f ByteSpan))
-> ByteString
-> Either DecoderError (f ByteSpan)
forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
lbl forall s. Decoder s (f ByteSpan)
decoder ByteString
bytes

-- | Reconstruct an annotation by re-serialising the payload to a ByteString.
reAnnotate :: ToCBOR a => Annotated a b -> Annotated a ByteString
reAnnotate :: Annotated a b -> Annotated a ByteString
reAnnotate (Annotated a
x b
_) = a -> ByteString -> Annotated a ByteString
forall b a. b -> a -> Annotated b a
Annotated a
x (a -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' a
x)

class Decoded t where
  type BaseType t :: Type
  recoverBytes :: t -> ByteString

instance Decoded (Annotated b ByteString) where
  type BaseType (Annotated b ByteString) = b
  recoverBytes :: Annotated b ByteString -> ByteString
recoverBytes = Annotated b ByteString -> ByteString
forall b a. Annotated b a -> a
annotation

-------------------------------------------------------------------------
-- Annotator
-------------------------------------------------------------------------

-- | This marks the entire bytestring used during decoding, rather than the
-- | piece we need to finish constructing our value.
newtype FullByteString = Full LByteString

-- | A value of type `Annotator a` is one that needs access to the entire
-- | bytestring used during decoding to finish construction.
newtype Annotator a = Annotator { Annotator a -> FullByteString -> a
runAnnotator :: FullByteString -> a }
  deriving newtype (Applicative Annotator
a -> Annotator a
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
Annotator a -> (a -> Annotator b) -> Annotator b
Annotator a -> Annotator b -> Annotator b
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
return :: a -> Annotator a
$creturn :: forall a. a -> Annotator a
>> :: Annotator a -> Annotator b -> Annotator b
$c>> :: forall a b. Annotator a -> Annotator b -> Annotator b
>>= :: Annotator a -> (a -> Annotator b) -> Annotator b
$c>>= :: forall a b. Annotator a -> (a -> Annotator b) -> Annotator b
$cp1Monad :: Applicative Annotator
Monad, Functor Annotator
a -> Annotator a
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
Annotator a -> Annotator b -> Annotator b
Annotator a -> Annotator b -> Annotator a
Annotator (a -> b) -> Annotator a -> Annotator b
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
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
<* :: Annotator a -> Annotator b -> Annotator a
$c<* :: forall a b. Annotator a -> Annotator b -> Annotator a
*> :: Annotator a -> Annotator b -> Annotator b
$c*> :: forall a b. Annotator a -> Annotator b -> Annotator b
liftA2 :: (a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Annotator a -> Annotator b -> Annotator c
<*> :: Annotator (a -> b) -> Annotator a -> Annotator b
$c<*> :: forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
pure :: a -> Annotator a
$cpure :: forall a. a -> Annotator a
$cp1Applicative :: Functor Annotator
Applicative, a -> Annotator b -> Annotator a
(a -> b) -> Annotator a -> Annotator b
(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
<$ :: a -> Annotator b -> Annotator a
$c<$ :: forall a b. a -> Annotator b -> Annotator a
fmap :: (a -> b) -> Annotator a -> Annotator b
$cfmap :: forall a b. (a -> b) -> Annotator a -> Annotator b
Functor)

-- | The argument is a decoder for a annotator that needs access to the bytes that
-- | were decoded. This function constructs and supplies the relevant piece.
annotatorSlice :: Decoder s (Annotator (LByteString -> a)) -> Decoder s (Annotator a)
annotatorSlice :: 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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
bytes

-- | Pairs the decoder result with an annotator.
withSlice :: Decoder s a -> Decoder s (a, Annotator LByteString)
withSlice :: Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s a
dec = do
  (a
r, ByteOffset
start, ByteOffset
end) <- Decoder s a -> Decoder s (a, ByteOffset, ByteOffset)
forall s a. Decoder s a -> Decoder s (a, ByteOffset, ByteOffset)
decodeWithByteSpan Decoder s a
dec
  (a, Annotator ByteString) -> Decoder s (a, Annotator ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, (FullByteString -> ByteString) -> Annotator ByteString
forall a. (FullByteString -> a) -> Annotator a
Annotator ((FullByteString -> ByteString) -> Annotator ByteString)
-> (FullByteString -> ByteString) -> Annotator ByteString
forall a b. (a -> b) -> a -> b
$ ByteOffset -> ByteOffset -> FullByteString -> ByteString
sliceOffsets ByteOffset
start ByteOffset
end)
  where
  sliceOffsets :: ByteOffset -> ByteOffset -> FullByteString -> LByteString
  sliceOffsets :: ByteOffset -> ByteOffset -> FullByteString -> ByteString
sliceOffsets ByteOffset
start ByteOffset
end (Full ByteString
b) = (ByteOffset -> ByteString -> ByteString
BSL.take (ByteOffset
end ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
- ByteOffset
start) (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteOffset -> ByteString -> ByteString
BSL.drop ByteOffset
start) ByteString
b

-- | Supplies the bytestring argument to both the decoder and the produced annotator.
decodeAnnotator :: Text -> (forall s. Decoder s (Annotator a)) -> LByteString -> Either DecoderError a
decodeAnnotator :: Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeAnnotator Text
label' forall s. Decoder s (Annotator a)
decoder ByteString
bytes =
  (\Annotator a
x -> Annotator a -> FullByteString -> a
forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator a
x (ByteString -> FullByteString
Full ByteString
bytes)) (Annotator a -> a)
-> Either DecoderError (Annotator a) -> Either DecoderError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError (Annotator a)
forall a.
Text
-> (forall s. Decoder s a) -> ByteString -> Either DecoderError a
decodeFullDecoder Text
label' forall s. Decoder s (Annotator a)
decoder ByteString
bytes