{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.State.Instances (
    -- * Serialisation support
    decodeCurrent
  , decodePast
  , encodeCurrent
  , encodePast
  ) where

import           Prelude hiding (sequence)

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Codec.Serialise
import           Data.SOP.Strict hiding (shape)
import           NoThunks.Class (NoThunks)

import           Cardano.Binary (enforceSize)

import           Ouroboros.Consensus.Util.SOP

import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import           Ouroboros.Consensus.HardFork.Combinator.State.Lift
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.HardFork.Combinator.Util.DerivingVia
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope

{-------------------------------------------------------------------------------
  SOP class instances

  These are convenient, allowing us to treat the 'HardForkState' just like any
  other SOP type; in particular, they deal with lifting functions to 'Current'.
-------------------------------------------------------------------------------}

type instance Prod       HardForkState   = NP
type instance SListIN    HardForkState   = SListI
type instance AllN       HardForkState c = All c
type instance CollapseTo HardForkState a = a

instance HAp HardForkState where
  hap :: Prod HardForkState (f -.-> g) xs
-> HardForkState f xs -> HardForkState g xs
hap Prod HardForkState (f -.-> g) xs
np (HardForkState Telescope (K Past) (Current f) xs
st) = Telescope (K Past) (Current g) xs -> HardForkState g xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current g) xs -> HardForkState g xs)
-> Telescope (K Past) (Current g) xs -> HardForkState g xs
forall a b. (a -> b) -> a -> b
$
      Prod (Telescope (K Past)) (Current f -.-> Current g) xs
-> Telescope (K Past) (Current f) xs
-> Telescope (K Past) (Current g) xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
hap ((forall a. (-.->) f g a -> (-.->) (Current f) (Current g) a)
-> NP (f -.-> g) xs -> NP (Current f -.-> Current g) xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NP f xs -> NP g xs
map_NP' ((Current f a -> Current g a) -> (-.->) (Current f) (Current g) a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(f a -> g a) -> (-.->) f g a
Fn ((Current f a -> Current g a) -> (-.->) (Current f) (Current g) a)
-> ((-.->) f g a -> Current f a -> Current g a)
-> (-.->) f g a
-> (-.->) (Current f) (Current g) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> g a) -> Current f a -> Current g a
forall (f :: * -> *) blk (f' :: * -> *).
(f blk -> f' blk) -> Current f blk -> Current f' blk
lift ((f a -> g a) -> Current f a -> Current g a)
-> ((-.->) f g a -> f a -> g a)
-> (-.->) f g a
-> Current f a
-> Current g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (-.->) f g a -> f a -> g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn) Prod HardForkState (f -.-> g) xs
NP (f -.-> g) xs
np) Telescope (K Past) (Current f) xs
st

instance HSequence HardForkState where
  hctraverse' :: proxy c
-> (forall a. c a => f a -> g (f' a))
-> HardForkState f xs
-> g (HardForkState f' xs)
hctraverse' = \proxy c
p forall a. c a => f a -> g (f' a)
f (HardForkState Telescope (K Past) (Current f) xs
st) -> Telescope (K Past) (Current f') xs -> HardForkState f' xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current f') xs -> HardForkState f' xs)
-> g (Telescope (K Past) (Current f') xs)
-> g (HardForkState f' xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                              proxy c
-> (forall a. c a => Current f a -> g (Current f' a))
-> Telescope (K Past) (Current f) xs
-> g (Telescope (K Past) (Current f') xs)
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
       (f :: k -> *) (f' :: k -> *).
(HSequence h, AllN h c xs, Applicative g) =>
proxy c
-> (forall (a :: k). c a => f a -> g (f' a))
-> h f xs
-> g (h f' xs)
hctraverse' proxy c
p ((f a -> g (f' a)) -> Current f a -> g (Current f' a)
forall (m :: * -> *) (f :: * -> *) blk (f' :: * -> *).
Functor m =>
(f blk -> m (f' blk)) -> Current f blk -> m (Current f' blk)
liftM f a -> g (f' a)
forall a. c a => f a -> g (f' a)
f) Telescope (K Past) (Current f) xs
st
  htraverse' :: (forall a. f a -> g (f' a))
-> HardForkState f xs -> g (HardForkState f' xs)
htraverse' = Proxy Top
-> (forall a. Top a => f a -> g (f' a))
-> HardForkState f xs
-> g (HardForkState f' xs)
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
       (f :: k -> *) (f' :: k -> *).
(HSequence h, AllN h c xs, Applicative g) =>
proxy c
-> (forall (a :: k). c a => f a -> g (f' a))
-> h f xs
-> g (h f' xs)
hctraverse' (Proxy Top
forall k (t :: k). Proxy t
Proxy @Top)
  hsequence' :: HardForkState (f :.: g) xs -> f (HardForkState g xs)
hsequence' = (forall a. (:.:) f g a -> f (g a))
-> HardForkState (f :.: g) xs -> f (HardForkState g xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (g :: * -> *)
       (f :: k -> *) (f' :: k -> *).
(HSequence h, SListIN h xs, Applicative g) =>
(forall (a :: k). f a -> g (f' a)) -> h f xs -> g (h f' xs)
htraverse' forall a. (:.:) f g a -> f (g a)
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
(:.:) f g p -> f (g p)
unComp

instance HCollapse HardForkState where
  hcollapse :: HardForkState (K a) xs -> CollapseTo HardForkState a
hcollapse = NS (K a) xs -> a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K a) xs -> a)
-> (HardForkState (K a) xs -> NS (K a) xs)
-> HardForkState (K a) xs
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Current (K a) a -> K a a)
-> NS (Current (K a)) xs -> NS (K a) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall a. Current (K a) a -> K a a
forall (f :: * -> *) blk. Current f blk -> f blk
currentState (NS (Current (K a)) xs -> NS (K a) xs)
-> (HardForkState (K a) xs -> NS (Current (K a)) xs)
-> HardForkState (K a) xs
-> NS (K a) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope (K Past) (Current (K a)) xs -> NS (Current (K a)) xs
forall k (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip (Telescope (K Past) (Current (K a)) xs -> NS (Current (K a)) xs)
-> (HardForkState (K a) xs
    -> Telescope (K Past) (Current (K a)) xs)
-> HardForkState (K a) xs
-> NS (Current (K a)) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState (K a) xs -> Telescope (K Past) (Current (K a)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState

{-------------------------------------------------------------------------------
  Eq, Show, NoThunks
-------------------------------------------------------------------------------}

deriving instance Eq       (f blk) => Eq       (Current f blk)
deriving instance Show     (f blk) => Show     (Current f blk)
deriving instance NoThunks (f blk) => NoThunks (Current f blk)

deriving via LiftTelescope (K Past) (Current f) xs
         instance ( All SingleEraBlock xs
                  , forall blk. SingleEraBlock blk => Show (f blk)
                  ) => Show (HardForkState f xs)

deriving via LiftTelescope (K Past) (Current f) xs
         instance ( All SingleEraBlock xs
                  , forall blk. SingleEraBlock blk => Eq (f blk)
                  ) => Eq (HardForkState f xs)

deriving via LiftNamedTelescope "HardForkState" (K Past) (Current f) xs
         instance ( All SingleEraBlock xs
                  , forall blk. SingleEraBlock blk => NoThunks (f blk)
                  ) => NoThunks (HardForkState f xs)

{-------------------------------------------------------------------------------
  Serialisation

  The 'Serialise' instances are primarily useful for the tests, but the general
  encoders/decoders are used by the HFC to store the ledger state.
-------------------------------------------------------------------------------}

encodeCurrent :: (f blk -> Encoding) -> Current f blk -> Encoding
encodeCurrent :: (f blk -> Encoding) -> Current f blk -> Encoding
encodeCurrent f blk -> Encoding
f Current{f blk
Bound
currentStart :: forall (f :: * -> *) blk. Current f blk -> Bound
currentState :: f blk
currentStart :: Bound
currentState :: forall (f :: * -> *) blk. Current f blk -> f blk
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , Bound -> Encoding
forall a. Serialise a => a -> Encoding
encode Bound
currentStart
    , f blk -> Encoding
f f blk
currentState
    ]

decodeCurrent :: Decoder s (f blk) -> Decoder s (Current f blk)
decodeCurrent :: Decoder s (f blk) -> Decoder s (Current f blk)
decodeCurrent Decoder s (f blk)
f = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"decodeCurrent" Int
2
    Bound
currentStart <- Decoder s Bound
forall a s. Serialise a => Decoder s a
decode
    f blk
currentState <- Decoder s (f blk)
f
    Current f blk -> Decoder s (Current f blk)
forall (m :: * -> *) a. Monad m => a -> m a
return Current :: forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current{f blk
Bound
currentState :: f blk
currentStart :: Bound
currentStart :: Bound
currentState :: f blk
..}

encodePast :: Past -> Encoding
encodePast :: Past -> Encoding
encodePast Past{Bound
pastEnd :: Past -> Bound
pastStart :: Past -> Bound
pastEnd :: Bound
pastStart :: Bound
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , Bound -> Encoding
forall a. Serialise a => a -> Encoding
encode Bound
pastStart
    , Bound -> Encoding
forall a. Serialise a => a -> Encoding
encode Bound
pastEnd
    ]

decodePast :: Decoder s Past
decodePast :: Decoder s Past
decodePast = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"decodePast" Int
2
    Bound
pastStart <- Decoder s Bound
forall a s. Serialise a => Decoder s a
decode
    Bound
pastEnd   <- Decoder s Bound
forall a s. Serialise a => Decoder s a
decode
    Past -> Decoder s Past
forall (m :: * -> *) a. Monad m => a -> m a
return Past :: Bound -> Bound -> Past
Past{Bound
pastEnd :: Bound
pastStart :: Bound
pastEnd :: Bound
pastStart :: Bound
..}

instance Serialise (f blk) => Serialise (Current f blk) where
  encode :: Current f blk -> Encoding
encode = (f blk -> Encoding) -> Current f blk -> Encoding
forall (f :: * -> *) blk.
(f blk -> Encoding) -> Current f blk -> Encoding
encodeCurrent f blk -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: Decoder s (Current f blk)
decode = Decoder s (f blk) -> Decoder s (Current f blk)
forall s (f :: * -> *) blk.
Decoder s (f blk) -> Decoder s (Current f blk)
decodeCurrent Decoder s (f blk)
forall a s. Serialise a => Decoder s a
decode

instance Serialise Past where
  encode :: Past -> Encoding
encode = Past -> Encoding
encodePast
  decode :: Decoder s Past
decode = Decoder s Past
forall s. Decoder s Past
decodePast