{-# 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,
  Mem,
  mkMemoBytes,
  getMemoBytesType,
  getMemoBytesHash,
  memoBytes,
  shorten,
  showMemo,
  printMemo,
  shortToLazy,
  contentsEq,

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

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

import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName))
import Cardano.Ledger.Binary (
  Annotated (..),
  Annotator (..),
  DecCBOR (decCBOR),
  Decoder,
  EncCBOR,
  decodeAnnotated,
  serialize,
  withSlice,
 )
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.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy as Lazy
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import qualified Data.ByteString.Short as SBS (length)
import Data.Coerce
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 era = Memo'
  { forall (t :: * -> *) era. MemoBytes t era -> t era
mbRawType :: !(t era)
  , forall (t :: * -> *) era. MemoBytes t era -> ShortByteString
mbBytes :: ShortByteString
  , forall (t :: * -> *) era.
MemoBytes t era -> 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 :: * -> *) era x.
Rep (MemoBytes t era) x -> MemoBytes t era
forall (t :: * -> *) era x.
MemoBytes t era -> Rep (MemoBytes t era) x
$cto :: forall (t :: * -> *) era x.
Rep (MemoBytes t era) x -> MemoBytes t era
$cfrom :: forall (t :: * -> *) era x.
MemoBytes t era -> Rep (MemoBytes t era) x
Generic)
  deriving (Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
Proxy (MemoBytes t era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (t :: * -> *) era.
(Typeable t, Typeable era, NoThunks (t era)) =>
Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
forall (t :: * -> *) era.
(Typeable t, Typeable era, NoThunks (t era)) =>
Proxy (MemoBytes t era) -> String
showTypeOf :: Proxy (MemoBytes t era) -> String
$cshowTypeOf :: forall (t :: * -> *) era.
(Typeable t, Typeable era, NoThunks (t era)) =>
Proxy (MemoBytes t era) -> String
wNoThunks :: Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (t :: * -> *) era.
(Typeable t, Typeable era, NoThunks (t era)) =>
Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
noThunks :: Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (t :: * -> *) era.
(Typeable t, Typeable era, NoThunks (t era)) =>
Context -> MemoBytes t era -> IO (Maybe ThunkInfo)
NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t era)

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

{-# COMPLETE Memo #-}

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

deriving instance NFData (t era) => NFData (MemoBytes t era)

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

instance
  (Typeable t, DecCBOR (Annotator (t era)), Era era) =>
  DecCBOR (Annotator (MemoBytes t era))
  where
  decCBOR :: forall s. Decoder s (Annotator (MemoBytes t era))
decCBOR = do
    (Annotator FullByteString -> t era
getT, Annotator FullByteString -> ByteString
getBytes) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (FullByteString -> a) -> Annotator a
Annotator (\FullByteString
fullbytes -> forall era (t :: * -> *). t era -> ByteString -> MemoBytes t era
mkMemoBytes (FullByteString -> t era
getT FullByteString
fullbytes) (FullByteString -> ByteString
getBytes FullByteString
fullbytes)))

instance (Typeable t, DecCBOR (t era), Era era) => DecCBOR (MemoBytes t era) where
  decCBOR :: forall s. Decoder s (MemoBytes t era)
decCBOR = forall s (t :: * -> *) era.
Decoder s (t era) -> Decoder s (MemoBytes t era)
decodeMemoized forall a s. DecCBOR a => Decoder s a
decCBOR

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

instance Show (t era) => Show (MemoBytes t era) where
  show :: MemoBytes t era -> String
show (Memo' t era
y ShortByteString
_ SafeHash (MemoHashIndex t)
h) =
    forall a. Show a => a -> String
show t era
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 era) where
  originalBytes :: MemoBytes t era -> ByteString
originalBytes = ShortByteString -> ByteString
fromShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) era. MemoBytes t era -> ShortByteString
mbBytes
  originalBytesSize :: MemoBytes t era -> Int
originalBytesSize = ShortByteString -> Int
SBS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) era. MemoBytes t era -> ShortByteString
mbBytes

-- | Turn a lazy bytestring into a short bytestring.
shorten :: Lazy.ByteString -> ShortByteString
shorten :: ByteString -> ShortByteString
shorten ByteString
x = ByteString -> ShortByteString
toShort (ByteString -> ByteString
toStrict ByteString
x)

-- | Useful when deriving DecCBOR(Annotator T)
-- deriving via (Mem T) instance (Era era) => DecCBOR (Annotator T)
type Mem t era = Annotator (MemoBytes t era)

-- | Smart constructor
mkMemoBytes :: forall era t. t era -> BSL.ByteString -> MemoBytes t era
mkMemoBytes :: forall era (t :: * -> *). t era -> ByteString -> MemoBytes t era
mkMemoBytes t era
t ByteString
bsl =
  forall (t :: * -> *) era.
t era
-> ShortByteString -> SafeHash (MemoHashIndex t) -> MemoBytes t era
Memo'
    t era
t
    (ByteString -> ShortByteString
toShort ByteString
bs)
    (forall t i. SafeToHash t => Proxy i -> t -> SafeHash i
makeHashWithExplicitProxys (forall {k} (t :: k). Proxy t
Proxy @(MemoHashIndex t)) ByteString
bs)
  where
    bs :: ByteString
bs = ByteString -> ByteString
toStrict ByteString
bsl

-- | 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 era) => MemoBytes t era -> String
showMemo :: forall (t :: * -> *) era. Show (t era) => MemoBytes t era -> String
showMemo (Memo' t era
t ShortByteString
b SafeHash (MemoHashIndex t)
_) = String
"(Memo " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t era
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
")"

printMemo :: Show (t era) => MemoBytes t era -> IO ()
printMemo :: forall (t :: * -> *) era. Show (t era) => MemoBytes t era -> IO ()
printMemo MemoBytes t era
x = String -> IO ()
putStrLn (forall (t :: * -> *) era. Show (t era) => MemoBytes t era -> String
showMemo MemoBytes t era
x)

-- | Create MemoBytes from its CBOR encoding
memoBytes :: forall era w t. Era era => Encode w (t era) -> MemoBytes t era
memoBytes :: forall era (w :: Wrapped) (t :: * -> *).
Era era =>
Encode w (t era) -> MemoBytes t era
memoBytes Encode w (t era)
t = forall era (t :: * -> *). t era -> ByteString -> MemoBytes t era
mkMemoBytes (forall (w :: Wrapped) t. Encode w t -> t
runE Encode w (t era)
t) (forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerLow @era) (forall (w :: Wrapped) t. Encode w t -> Encoding
encode Encode w (t era)
t))

-- | 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

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

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

-- | Extract the hash value of the binary representation of the MemoBytes
getMemoBytesHash :: MemoBytes t era -> SafeHash (MemoHashIndex t)
getMemoBytesHash :: forall (t :: * -> *) era.
MemoBytes t era -> SafeHash (MemoHashIndex t)
getMemoBytesHash = forall (t :: * -> *) era.
MemoBytes t era -> 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 -> 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 era -> MemoBytes (RawType t) era
  default getMemoBytes ::
    Coercible (t era) (MemoBytes (RawType t) era) =>
    t era ->
    MemoBytes (RawType t) era
  getMemoBytes = coerce :: forall a b. Coercible a b => a -> b
coerce

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

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

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

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

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

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

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

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

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

-- | This is a helper SimpleGetter creator for any Memoized type
getterMemoRawType ::
  Memoized t =>
  (RawType t era -> a) ->
  SimpleGetter (t era) a
getterMemoRawType :: forall (t :: * -> *) era a.
Memoized t =>
(RawType t era -> a) -> SimpleGetter (t era) a
getterMemoRawType RawType t era -> a
getter =
  forall s a. (s -> a) -> SimpleGetter s a
to (RawType t era -> a
getter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) era. Memoized t => t era -> RawType t era
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 era, Memoized t, Eq (RawType t era)) => a -> a -> Bool
  eqRaw = forall (t :: * -> *) era.
(Memoized t, Eq (RawType t era)) =>
t era -> t era -> Bool
eqRawType