{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Provides MemoBytes internals
--
-- = Warning
--
-- This module is considered __internal__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
module Cardano.Ledger.MemoBytes.Internal (
  MemoBytes (.., Memo),
  MemoHashIndex,
  mkMemoBytes,
  mkMemoBytesStrict,
  getMemoBytesType,
  getMemoBytesHash,
  memoBytes,
  memoBytesEra,
  shorten,
  showMemo,
  printMemo,
  shortToLazy,
  contentsEq,
  decodeMemoBytes,

  -- * Memoized
  Memoized (RawType),
  mkMemoized,
  mkMemoizedEra,
  decodeMemoized,
  getMemoSafeHash,
  getMemoRawType,
  zipMemoRawType,
  eqRawType,
  getMemoRawBytes,
  lensMemoRawType,
  getterMemoRawType,

  -- * MemoBytes MemPack instance definitions
  byteCountMemoBytes,
  packMemoBytesM,
  unpackMemoBytesM,

  -- * Raw equality
  EqRaw (..),
)
where

import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName))
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (decCBOR),
  Decoder,
  EncCBOR,
  Version,
  decodeAnnotated,
  decodeFull',
  serialize,
 )
import Cardano.Ledger.Binary.Coders (Encode, encode, runE)
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core.Era (Era, eraProtVerLow)
import Cardano.Ledger.Hashes (HASH, SafeHash, SafeToHash (..))
import Control.DeepSeq (NFData (..))
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import qualified Data.ByteString.Short as SBS (length)
import Data.Coerce
import Data.MemPack
import Data.MemPack.Buffer (Buffer)
import Data.Typeable
import GHC.Base (Type)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
import Prelude hiding (span)

-- ========================================================================

-- | Pair together a type @t@ and its serialization. Used to encode a type
--   that is serialized over the network, and to remember the original bytes
--   that were used to transmit it. Important since hashes are computed
--   from the serialization of a type, and EncCBOR instances do not have unique
--   serializations.
data MemoBytes t = MemoBytes
  { forall t. MemoBytes t -> t
mbRawType :: !t
  , forall t. MemoBytes t -> ShortByteString
mbBytes :: ShortByteString
  , forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash :: SafeHash (MemoHashIndex t)
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (MemoBytes t) x -> MemoBytes t
forall t x. MemoBytes t -> Rep (MemoBytes t) x
$cto :: forall t x. Rep (MemoBytes t) x -> MemoBytes t
$cfrom :: forall t x. MemoBytes t -> Rep (MemoBytes t) x
Generic)
  deriving (Context -> MemoBytes t -> IO (Maybe ThunkInfo)
Proxy (MemoBytes t) -> String
forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
forall t. (Typeable t, NoThunks t) => Proxy (MemoBytes t) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MemoBytes t) -> String
$cshowTypeOf :: forall t. (Typeable t, NoThunks t) => Proxy (MemoBytes t) -> String
wNoThunks :: Context -> MemoBytes t -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
noThunks :: Context -> MemoBytes t -> IO (Maybe ThunkInfo)
$cnoThunks :: forall t.
(Typeable t, NoThunks t) =>
Context -> MemoBytes t -> IO (Maybe ThunkInfo)
NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t)

pattern Memo :: t -> ShortByteString -> MemoBytes t
pattern $bMemo :: forall t. t -> ShortByteString -> MemoBytes t
$mMemo :: forall {r} {t}.
MemoBytes t -> (t -> ShortByteString -> r) -> ((# #) -> r) -> r
Memo memoType memoBytes <-
  MemoBytes memoType memoBytes _
  where
    Memo t
mt ShortByteString
mb = forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
mt (ShortByteString -> ByteString
shortToLazy ShortByteString
mb)

{-# COMPLETE Memo #-}

byteCountMemoBytes :: MemoBytes t -> Int
byteCountMemoBytes :: forall t. MemoBytes t -> Int
byteCountMemoBytes = forall a. MemPack a => a -> Int
packedByteCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

packMemoBytesM :: MemoBytes t -> Pack s ()
packMemoBytesM :: forall t s. MemoBytes t -> Pack s ()
packMemoBytesM = forall a s. MemPack a => a -> Pack s ()
packM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

unpackMemoBytesM :: (DecCBOR t, Buffer b) => Version -> Unpack b (MemoBytes t)
unpackMemoBytesM :: forall t b.
(DecCBOR t, Buffer b) =>
Version -> Unpack b (MemoBytes t)
unpackMemoBytesM Version
v = forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t (m :: * -> *).
(DecCBOR t, MonadFail m) =>
Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes Version
v

decodeMemoBytes :: (DecCBOR t, MonadFail m) => Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes :: forall t (m :: * -> *).
(DecCBOR t, MonadFail m) =>
Version -> ByteString -> m (MemoBytes t)
decodeMemoBytes Version
v = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
v

type family MemoHashIndex (t :: Type) :: Type

deriving instance NFData t => NFData (MemoBytes t)

instance Typeable t => Plain.ToCBOR (MemoBytes t) where
  toCBOR :: MemoBytes t -> Encoding
toCBOR (MemoBytes t
_ ShortByteString
bytes SafeHash (MemoHashIndex t)
_hash) = ByteString -> Encoding
Plain.encodePreEncoded (ShortByteString -> ByteString
fromShort ShortByteString
bytes)

instance DecCBOR t => DecCBOR (MemoBytes t) where
  decCBOR :: forall s. Decoder s (MemoBytes t)
decCBOR = forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Both binary representation and Haskell types are compared.
instance Eq t => Eq (MemoBytes t) where
  MemoBytes t
x == :: MemoBytes t -> MemoBytes t -> Bool
== MemoBytes t
y = forall t. MemoBytes t -> ShortByteString
mbBytes MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> ShortByteString
mbBytes MemoBytes t
y Bool -> Bool -> Bool
&& forall t. MemoBytes t -> t
mbRawType MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> t
mbRawType MemoBytes t
y

instance Show t => Show (MemoBytes t) where
  show :: MemoBytes t -> String
show (MemoBytes t
y ShortByteString
_ SafeHash (MemoHashIndex t)
h) =
    forall a. Show a => a -> String
show t
y
      forall a. Semigroup a => a -> a -> a
<> String
" ("
      forall a. Semigroup a => a -> a -> a
<> forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> String
hashAlgorithmName (forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      forall a. Semigroup a => a -> a -> a
<> String
": "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SafeHash (MemoHashIndex t)
h
      forall a. Semigroup a => a -> a -> a
<> String
")"

instance SafeToHash (MemoBytes t) where
  originalBytes :: MemoBytes t -> ByteString
originalBytes = ShortByteString -> ByteString
fromShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes
  originalBytesSize :: MemoBytes t -> Int
originalBytesSize = ShortByteString -> Int
SBS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MemoBytes t -> ShortByteString
mbBytes

-- | Turn a lazy bytestring into a short bytestring.
shorten :: BSL.ByteString -> ShortByteString
shorten :: ByteString -> ShortByteString
shorten ByteString
x = ByteString -> ShortByteString
toShort (ByteString -> ByteString
toStrict ByteString
x)
{-# DEPRECATED shorten "As unused. Use `toShort` `.` `toStrict` instead" #-}

-- | Constructor that takes the underlying type and the original bytes as lazy
-- `BSL.ByteString`.
--
-- /Warning/ - This is a dangerous constructor because it allows one to construct a `MemoBytes` type
-- with wrong bytes.
mkMemoBytes :: t -> BSL.ByteString -> MemoBytes t
mkMemoBytes :: forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
t = forall t. t -> ByteString -> MemoBytes t
mkMemoBytesStrict t
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict

-- | Same as `mkMemoBytes`, but with strict bytes
mkMemoBytesStrict :: forall t. t -> ByteString -> MemoBytes t
mkMemoBytesStrict :: forall t. t -> ByteString -> MemoBytes t
mkMemoBytesStrict t
t ByteString
bs =
  forall t.
t -> ShortByteString -> SafeHash (MemoHashIndex t) -> MemoBytes t
MemoBytes t
t (ByteString -> ShortByteString
toShort ByteString
bs) forall a b. (a -> b) -> a -> b
$
    forall t i. SafeToHash t => Proxy i -> t -> SafeHash i
makeHashWithExplicitProxys (forall {k} (t :: k). Proxy t
Proxy @(MemoHashIndex t)) ByteString
bs

-- | Turn a MemoBytes into a string, showing both its internal structure and its original bytes.
--   Useful since the Show instance of MemoBytes does not display the original bytes.
showMemo :: Show t => MemoBytes t -> String
showMemo :: forall t. Show t => MemoBytes t -> String
showMemo (MemoBytes t
t ShortByteString
b SafeHash (MemoHashIndex t)
_) = String
"(Memo " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
t forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ShortByteString
b forall a. [a] -> [a] -> [a]
++ String
")"
{-# DEPRECATED showMemo "As unused. Show instance will show the hash, which is enough most of the time" #-}

printMemo :: Show t => MemoBytes t -> IO ()
printMemo :: forall t. Show t => MemoBytes t -> IO ()
printMemo MemoBytes t
x = String -> IO ()
putStrLn (forall t. Show t => MemoBytes t -> String
showMemo MemoBytes t
x)
{-# DEPRECATED printMemo "As unused. Show instance will show the hash, which is enough most of the time" #-}

-- | Create MemoBytes from its CBOR encoding
--
-- /Warning/ - This is a dangerous constructor because it allows one to construct a `MemoBytes` type
-- from the wrong encoding. Use `mkMemoized` instead when possible.
memoBytes :: Version -> Encode w t -> MemoBytes t
memoBytes :: forall (w :: Wrapped) t. Version -> Encode w t -> MemoBytes t
memoBytes Version
v Encode w t
t = forall t. t -> ByteString -> MemoBytes t
mkMemoBytes (forall (w :: Wrapped) t. Encode w t -> t
runE Encode w t
t) (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
v (forall (w :: Wrapped) t. Encode w t -> Encoding
encode Encode w t
t))

-- | Same as `memoBytes`, but derives `Version` from the era.
--
-- /Warning/ - This is a dangerous constructor because it allows one to construct a `MemoBytes` type
-- from the wrong encoding. Use `mkMemoizedEra` instead when possible.
memoBytesEra :: forall era w t. Era era => Encode w t -> MemoBytes t
memoBytesEra :: forall era (w :: Wrapped) t. Era era => Encode w t -> MemoBytes t
memoBytesEra = forall (w :: Wrapped) t. Version -> Encode w t -> MemoBytes t
memoBytes (forall era. Era era => Version
eraProtVerLow @era)

-- | Helper function. Converts a short bytestring to a lazy bytestring.
shortToLazy :: ShortByteString -> BSL.ByteString
shortToLazy :: ShortByteString -> ByteString
shortToLazy = ByteString -> ByteString
fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
fromShort
{-# INLINE shortToLazy #-}

-- | Returns true if the contents of the MemoBytes are equal
contentsEq :: Eq t => MemoBytes t -> MemoBytes t -> Bool
contentsEq :: forall t. Eq t => MemoBytes t -> MemoBytes t -> Bool
contentsEq MemoBytes t
x MemoBytes t
y = forall t. MemoBytes t -> t
mbRawType MemoBytes t
x forall a. Eq a => a -> a -> Bool
== forall t. MemoBytes t -> t
mbRawType MemoBytes t
y

-- | Extract the inner type of the MemoBytes
getMemoBytesType :: MemoBytes t -> t
getMemoBytesType :: forall t. MemoBytes t -> t
getMemoBytesType = forall t. MemoBytes t -> t
mbRawType

-- | Extract the hash value of the binary representation of the MemoBytes
getMemoBytesHash :: MemoBytes t -> SafeHash (MemoHashIndex t)
getMemoBytesHash :: forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
getMemoBytesHash = forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash

-- | Class that relates the actual type with its raw and byte representations
class Memoized t where
  type RawType t = (r :: Type) | r -> t

  -- | This is a coercion from the memoized type to the MemoBytes. This implementation
  -- cannot be changed since `getMemoBytes` is not exported, therefore it will only work
  -- on newtypes around `MemoBytes`
  getMemoBytes :: t -> MemoBytes (RawType t)
  default getMemoBytes ::
    Coercible t (MemoBytes (RawType t)) =>
    t ->
    MemoBytes (RawType t)
  getMemoBytes = coerce :: forall a b. Coercible a b => a -> b
coerce

  -- | This is a coercion from the MemoBytes to the memoized type. This implementation
  -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work
  -- on newtypes around `MemoBytes`
  wrapMemoBytes :: MemoBytes (RawType t) -> t
  default wrapMemoBytes ::
    Coercible (MemoBytes (RawType t)) t =>
    MemoBytes (RawType t) ->
    t
  wrapMemoBytes = coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Construct memoized type from the raw type using its EncCBOR instance
mkMemoized :: forall t. (EncCBOR (RawType t), Memoized t) => Version -> RawType t -> t
mkMemoized :: forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized Version
v RawType t
rawType = forall t. Memoized t => MemoBytes (RawType t) -> t
wrapMemoBytes (forall t. t -> ByteString -> MemoBytes t
mkMemoBytes RawType t
rawType (forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
v RawType t
rawType))

mkMemoizedEra :: forall era t. (Era era, EncCBOR (RawType t), Memoized t) => RawType t -> t
mkMemoizedEra :: forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra = forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized (forall era. Era era => Version
eraProtVerLow @era)

decodeMemoized :: Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized :: forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized Decoder s t
rawTypeDecoder = do
  Annotated t
rawType ByteString
lazyBytes <- forall s a. Decoder s a -> Decoder s (Annotated a ByteString)
decodeAnnotated Decoder s t
rawTypeDecoder
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t. t -> ByteString -> MemoBytes t
mkMemoBytes t
rawType ByteString
lazyBytes

-- | Extract memoized SafeHash
getMemoSafeHash :: Memoized t => t -> SafeHash (MemoHashIndex (RawType t))
getMemoSafeHash :: forall t. Memoized t => t -> SafeHash (MemoHashIndex (RawType t))
getMemoSafeHash t
t = forall t. MemoBytes t -> SafeHash (MemoHashIndex t)
mbHash (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | Extract the raw type from the memoized version
getMemoRawType :: Memoized t => t -> RawType t
getMemoRawType :: forall t. Memoized t => t -> RawType t
getMemoRawType t
t = forall t. MemoBytes t -> t
mbRawType (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | Extract the raw bytes from the memoized version
getMemoRawBytes :: Memoized t => t -> ShortByteString
getMemoRawBytes :: forall t. Memoized t => t -> ShortByteString
getMemoRawBytes t
t = forall t. MemoBytes t -> ShortByteString
mbBytes (forall t. Memoized t => t -> MemoBytes (RawType t)
getMemoBytes t
t)

-- | This is a helper function that operates on raw types of two memoized types.
zipMemoRawType ::
  (Memoized t1, Memoized t2) =>
  (RawType t1 -> RawType t2 -> a) ->
  t1 ->
  t2 ->
  a
zipMemoRawType :: forall t1 t2 a.
(Memoized t1, Memoized t2) =>
(RawType t1 -> RawType t2 -> a) -> t1 -> t2 -> a
zipMemoRawType RawType t1 -> RawType t2 -> a
f t1
x t2
y = RawType t1 -> RawType t2 -> a
f (forall t. Memoized t => t -> RawType t
getMemoRawType t1
x) (forall t. Memoized t => t -> RawType t
getMemoRawType t2
y)

eqRawType ::
  forall t.
  (Memoized t, Eq (RawType t)) =>
  t ->
  t ->
  Bool
eqRawType :: forall t. (Memoized t, Eq (RawType t)) => t -> t -> Bool
eqRawType = forall t1 t2 a.
(Memoized t1, Memoized t2) =>
(RawType t1 -> RawType t2 -> a) -> t1 -> t2 -> a
zipMemoRawType @t forall a. Eq a => a -> a -> Bool
(==)

-- | This is a helper Lens creator for any Memoized type.
lensMemoRawType ::
  forall era t a b.
  (Era era, EncCBOR (RawType t), Memoized t) =>
  (RawType t -> a) ->
  (RawType t -> b -> RawType t) ->
  Lens t t a b
lensMemoRawType :: forall era t a b.
(Era era, EncCBOR (RawType t), Memoized t) =>
(RawType t -> a) -> (RawType t -> b -> RawType t) -> Lens t t a b
lensMemoRawType RawType t -> a
getter RawType t -> b -> RawType t
setter =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (RawType t -> a
getter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Memoized t => t -> RawType t
getMemoRawType) (\t
t b
b -> forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall a b. (a -> b) -> a -> b
$ RawType t -> b -> RawType t
setter (forall t. Memoized t => t -> RawType t
getMemoRawType t
t) b
b)
{-# INLINEABLE lensMemoRawType #-}

-- | This is a helper SimpleGetter creator for any Memoized type
getterMemoRawType ::
  Memoized t =>
  (RawType t -> a) ->
  SimpleGetter t a
getterMemoRawType :: forall t a. Memoized t => (RawType t -> a) -> SimpleGetter t a
getterMemoRawType RawType t -> a
getter =
  forall s a. (s -> a) -> SimpleGetter s a
to (RawType t -> a
getter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Memoized t => t -> RawType t
getMemoRawType)
{-# INLINEABLE getterMemoRawType #-}

-- | Type class that implements equality on the Haskell type, ignoring any of the
-- potentially memoized binary representation of the type.
class EqRaw a where
  eqRaw :: a -> a -> Bool
  default eqRaw :: (a ~ t, Memoized t, Eq (RawType t)) => a -> a -> Bool
  eqRaw = forall t. (Memoized t, Eq (RawType t)) => t -> t -> Bool
eqRawType