{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.RealPoint (
    -- * Non-genesis points
    RealPoint (..)
  , decodeRealPoint
  , encodeRealPoint
    -- * Derived
  , blockRealPoint
  , headerRealPoint
  , pointToWithOriginRealPoint
  , realPointHash
  , realPointSlot
  , realPointToPoint
  , withOriginRealPointToPoint
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Codec.Serialise (decode, encode)
import           Data.Proxy
import           Data.Typeable (Typeable, typeRep)
import           GHC.Generics
import           NoThunks.Class (NoThunks (..))

import           Cardano.Binary (enforceSize)

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  Non-genesis point
-------------------------------------------------------------------------------}

-- | Point of an actual block (i.e., not genesis)
data RealPoint blk = RealPoint !SlotNo !(HeaderHash blk)
  deriving ((forall x. RealPoint blk -> Rep (RealPoint blk) x)
-> (forall x. Rep (RealPoint blk) x -> RealPoint blk)
-> Generic (RealPoint blk)
forall x. Rep (RealPoint blk) x -> RealPoint blk
forall x. RealPoint blk -> Rep (RealPoint blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (RealPoint blk) x -> RealPoint blk
forall blk x. RealPoint blk -> Rep (RealPoint blk) x
$cto :: forall blk x. Rep (RealPoint blk) x -> RealPoint blk
$cfrom :: forall blk x. RealPoint blk -> Rep (RealPoint blk) x
Generic)

-- TODO: The Ord instance should go
-- <https://github.com/input-output-hk/ouroboros-network/issues/1693>
deriving instance StandardHash blk => Eq   (RealPoint blk)
deriving instance StandardHash blk => Ord  (RealPoint blk)
deriving instance StandardHash blk => Show (RealPoint blk)

instance (StandardHash blk, Typeable blk)
      => NoThunks (RealPoint blk) where
  showTypeOf :: Proxy (RealPoint blk) -> String
showTypeOf Proxy (RealPoint blk)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (RealPoint blk) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (RealPoint blk)
forall k (t :: k). Proxy t
Proxy @(RealPoint blk))

instance Condense (HeaderHash blk) => Condense (RealPoint blk) where
  condense :: RealPoint blk -> String
condense (RealPoint SlotNo
s HeaderHash blk
h) = String
"(Point " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> String
forall a. Condense a => a -> String
condense HeaderHash blk
h String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

encodeRealPoint :: (HeaderHash blk -> Encoding)
                -> (RealPoint  blk -> Encoding)
encodeRealPoint :: (HeaderHash blk -> Encoding) -> RealPoint blk -> Encoding
encodeRealPoint HeaderHash blk -> Encoding
encodeHash (RealPoint SlotNo
s HeaderHash blk
h) = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
s
    , HeaderHash blk -> Encoding
encodeHash HeaderHash blk
h
    ]

decodeRealPoint :: (forall s. Decoder s (HeaderHash blk))
                -> (forall s. Decoder s (RealPoint  blk))
decodeRealPoint :: (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint forall s. Decoder s (HeaderHash blk)
decodeHash = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"RealPoint" Int
2
    SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (SlotNo -> HeaderHash blk -> RealPoint blk)
-> Decoder s SlotNo -> Decoder s (HeaderHash blk -> RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash blk -> RealPoint blk)
-> Decoder s (HeaderHash blk) -> Decoder s (RealPoint blk)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHash

{-------------------------------------------------------------------------------
  Derived
-------------------------------------------------------------------------------}

realPointSlot :: RealPoint blk -> SlotNo
realPointSlot :: RealPoint blk -> SlotNo
realPointSlot (RealPoint SlotNo
s HeaderHash blk
_) = SlotNo
s

realPointHash :: RealPoint blk -> HeaderHash blk
realPointHash :: RealPoint blk -> HeaderHash blk
realPointHash (RealPoint SlotNo
_ HeaderHash blk
h) = HeaderHash blk
h

blockRealPoint :: HasHeader blk => blk -> RealPoint blk
blockRealPoint :: blk -> RealPoint blk
blockRealPoint blk
blk = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h
  where
    HeaderFields { headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot = SlotNo
s, headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
headerFieldHash = HeaderHash blk
h } = blk -> HeaderFields blk
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields blk
blk

headerRealPoint :: HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint :: Header blk -> RealPoint blk
headerRealPoint Header blk
hdr = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h
  where
    HeaderFields { headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot = SlotNo
s, headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
headerFieldHash = HeaderHash (Header blk)
h } = Header blk -> HeaderFields (Header blk)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields Header blk
hdr

realPointToPoint :: RealPoint blk -> Point blk
realPointToPoint :: RealPoint blk -> Point blk
realPointToPoint (RealPoint SlotNo
s HeaderHash blk
h) = SlotNo -> HeaderHash blk -> Point blk
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s HeaderHash blk
h

withOriginRealPointToPoint :: WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint :: WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint WithOrigin (RealPoint blk)
Origin        = Point blk
forall block. Point block
GenesisPoint
withOriginRealPointToPoint (NotOrigin RealPoint blk
p) = RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
p

pointToWithOriginRealPoint :: Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint :: Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
GenesisPoint     = WithOrigin (RealPoint blk)
forall t. WithOrigin t
Origin
pointToWithOriginRealPoint (BlockPoint SlotNo
s HeaderHash blk
h) = RealPoint blk -> WithOrigin (RealPoint blk)
forall t. t -> WithOrigin t
NotOrigin (RealPoint blk -> WithOrigin (RealPoint blk))
-> RealPoint blk -> WithOrigin (RealPoint blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h