{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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           Cardano.Binary (enforceSize)
import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Codec.Serialise
import           Data.Coerce
import           Data.Proxy
import           Data.SOP.BasicFunctors
import           Data.SOP.Constraint
import           Data.SOP.Strict
import qualified Data.SOP.Telescope as Telescope
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import           Ouroboros.Consensus.HardFork.Combinator.Lifting
import           Ouroboros.Consensus.HardFork.Combinator.State.Lift
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Prelude hiding (sequence)

{-------------------------------------------------------------------------------
  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 :: forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
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
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod (Telescope (K Past)) (f -.-> g) xs
-> Telescope (K Past) f xs -> Telescope (K Past) 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' :: forall (c :: * -> Constraint) (xs :: [*]) (g :: * -> *)
       (proxy :: (* -> Constraint) -> *) (f :: * -> *) (f' :: * -> *).
(AllN HardForkState c xs, Applicative g) =>
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)
forall (c :: * -> Constraint) (xs :: [*]) (g :: * -> *)
       (proxy :: (* -> Constraint) -> *) (f :: * -> *) (f' :: * -> *).
(AllN (Telescope (K Past)) c xs, Applicative g) =>
proxy c
-> (forall a. c a => f a -> g (f' a))
-> Telescope (K Past) f xs
-> g (Telescope (K Past) 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 (xs :: [*]) (g :: * -> *) (f :: * -> *) (f' :: * -> *).
(SListIN HardForkState xs, Applicative g) =>
(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)
forall (c :: * -> Constraint) (xs :: [*]) (g :: * -> *)
       (proxy :: (* -> Constraint) -> *) (f :: * -> *) (f' :: * -> *).
(AllN HardForkState c xs, Applicative g) =>
proxy c
-> (forall a. c a => f a -> g (f' a))
-> HardForkState f xs
-> g (HardForkState f' xs)
hctraverse' (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Top)
  hsequence' :: forall (xs :: [*]) (f :: * -> *) (g :: * -> *).
(SListIN HardForkState xs, Applicative f) =>
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 (xs :: [*]) (g :: * -> *) (f :: * -> *) (f' :: * -> *).
(SListIN HardForkState xs, Applicative g) =>
(forall a. f a -> g (f' a))
-> HardForkState f xs -> g (HardForkState f' 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' (:.:) f g a -> f (g a)
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 :: forall (xs :: [*]) a.
SListIN HardForkState xs =>
HardForkState (K a) xs -> CollapseTo HardForkState a
hcollapse = NS (K a) xs -> a
NS (K a) xs -> CollapseTo NS a
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS 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 Current (K a) a -> K a a
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

instance HTrans HardForkState HardForkState where
  htrans :: forall (c :: * -> * -> Constraint) (xs :: [*]) (ys :: [*])
       (proxy :: (* -> * -> Constraint) -> *) (f :: * -> *) (g :: * -> *).
AllZipN (Prod HardForkState) c xs ys =>
proxy c
-> (forall x y. c x y => f x -> g y)
-> HardForkState f xs
-> HardForkState g ys
htrans proxy c
p forall x y. c x y => f x -> g y
t (HardForkState Telescope (K Past) (Current f) xs
st) = Telescope (K Past) (Current g) ys -> HardForkState g ys
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current g) ys -> HardForkState g ys)
-> Telescope (K Past) (Current g) ys -> HardForkState g ys
forall a b. (a -> b) -> a -> b
$
      proxy c
-> (forall x y. c x y => Current f x -> Current g y)
-> Telescope (K Past) (Current f) xs
-> Telescope (K Past) (Current g) ys
forall k1 l1 k2 l2 (h1 :: (k1 -> *) -> l1 -> *)
       (h2 :: (k2 -> *) -> l2 -> *) (c :: k1 -> k2 -> Constraint)
       (xs :: l1) (ys :: l2) (proxy :: (k1 -> k2 -> Constraint) -> *)
       (f :: k1 -> *) (g :: k2 -> *).
(HTrans h1 h2, AllZipN (Prod h1) c xs ys) =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> h1 f xs
-> h2 g ys
forall (c :: * -> * -> Constraint) (xs :: [*]) (ys :: [*])
       (proxy :: (* -> * -> Constraint) -> *) (f :: * -> *) (g :: * -> *).
AllZipN (Prod (Telescope (K Past))) c xs ys =>
proxy c
-> (forall x y. c x y => f x -> g y)
-> Telescope (K Past) f xs
-> Telescope (K Past) g ys
htrans proxy c
p (\(Current Bound
b f x
fx) -> Bound -> g y -> Current g y
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
b (g y -> Current g y) -> g y -> Current g y
forall a b. (a -> b) -> a -> b
$ f x -> g y
forall x y. c x y => f x -> g y
t f x
fx) Telescope (K Past) (Current f) xs
st

  hcoerce ::
       forall f g xs ys. AllZipN (Prod HardForkState) (LiftedCoercible f g) xs ys
    => HardForkState f xs
    -> HardForkState g ys
  hcoerce :: forall (f :: * -> *) (g :: * -> *) (xs :: [*]) (ys :: [*]).
AllZipN (Prod HardForkState) (LiftedCoercible f g) xs ys =>
HardForkState f xs -> HardForkState g ys
hcoerce (HardForkState Telescope (K Past) (Current f) xs
st) = Telescope (K Past) (Current g) ys -> HardForkState g ys
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current g) ys -> HardForkState g ys)
-> Telescope (K Past) (Current g) ys -> HardForkState g ys
forall a b. (a -> b) -> a -> b
$
      Proxy (LiftedCoercible f g)
-> (forall x y.
    LiftedCoercible f g x y =>
    Current f x -> Current g y)
-> Telescope (K Past) (Current f) xs
-> Telescope (K Past) (Current g) ys
forall k1 l1 k2 l2 (h1 :: (k1 -> *) -> l1 -> *)
       (h2 :: (k2 -> *) -> l2 -> *) (c :: k1 -> k2 -> Constraint)
       (xs :: l1) (ys :: l2) (proxy :: (k1 -> k2 -> Constraint) -> *)
       (f :: k1 -> *) (g :: k2 -> *).
(HTrans h1 h2, AllZipN (Prod h1) c xs ys) =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> h1 f xs
-> h2 g ys
forall (c :: * -> * -> Constraint) (xs :: [*]) (ys :: [*])
       (proxy :: (* -> * -> Constraint) -> *) (f :: * -> *) (g :: * -> *).
AllZipN (Prod (Telescope (K Past))) c xs ys =>
proxy c
-> (forall x y. c x y => f x -> g y)
-> Telescope (K Past) f xs
-> Telescope (K Past) g ys
htrans
        (forall {k} (t :: k). Proxy t
forall (t :: * -> * -> Constraint). Proxy t
Proxy @(LiftedCoercible f g))
        (\(Current Bound
b f x
fx) -> Bound -> g y -> Current g y
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
b (g y -> Current g y) -> g y -> Current g y
forall a b. (a -> b) -> a -> b
$ f x -> g y
forall a b. Coercible a b => a -> b
coerce f x
fx)
        Telescope (K Past) (Current f) xs
st

type instance Same HardForkState = HardForkState

{-------------------------------------------------------------------------------
  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 :: forall (f :: * -> *) blk.
(f blk -> Encoding) -> Current f blk -> Encoding
encodeCurrent f blk -> Encoding
f Current{f blk
Bound
currentState :: forall (f :: * -> *) blk. Current f blk -> f blk
currentStart :: Bound
currentState :: f blk
currentStart :: forall (f :: * -> *) blk. Current f blk -> 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
currentStart
    , f blk -> Encoding
f f blk
currentState
    ]

decodeCurrent :: Decoder s (f blk) -> Decoder s (Current f blk)
decodeCurrent :: forall s (f :: * -> *) blk.
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 s. 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 a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return Current{f blk
Bound
currentState :: f blk
currentStart :: Bound
currentStart :: Bound
currentState :: f blk
..}

encodePast :: Past -> Encoding
encodePast :: Past -> Encoding
encodePast Past{Bound
pastStart :: Bound
pastEnd :: Bound
pastStart :: Past -> Bound
pastEnd :: Past -> 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 :: forall s. 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 s. Decoder s Bound
forall a s. Serialise a => Decoder s a
decode
    Bound
pastEnd   <- Decoder s Bound
forall s. Decoder s Bound
forall a s. Serialise a => Decoder s a
decode
    Past -> Decoder s Past
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return Past{Bound
pastStart :: Bound
pastEnd :: Bound
pastStart :: Bound
pastEnd :: 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 :: forall s. 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 s. 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 :: forall s. Decoder s Past
decode = Decoder s Past
forall s. Decoder s Past
decodePast