{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Condense instances
--
-- These are for the benefit of integration and tests. We do not rely on them
-- within consensus.
--
-- NOTE: No guarantees are made about what these condense instances look like.
module Ouroboros.Consensus.HardFork.Combinator.Condense (CondenseConstraints) where

import           Data.Coerce
import           Data.SOP.Strict

import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  Infrastructure
-------------------------------------------------------------------------------}

class ( Condense blk
      , Condense (Header blk)
      , Condense (GenTx blk)
      , Condense (GenTxId blk)
      ) => CondenseConstraints blk

pCondense :: Proxy CondenseConstraints
pCondense :: Proxy CondenseConstraints
pCondense = Proxy CondenseConstraints
forall k (t :: k). Proxy t
Proxy

defaultCondenseNS :: ( All CondenseConstraints xs
                     , forall blk. CondenseConstraints blk => Condense (f blk)
                     )
                  => Proxy f -> NS f xs -> String
defaultCondenseNS :: Proxy f -> NS f xs -> String
defaultCondenseNS Proxy f
_ = NS (K String) xs -> String
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K String) xs -> String)
-> (NS f xs -> NS (K String) xs) -> NS f xs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy CondenseConstraints
-> (forall a. CondenseConstraints a => f a -> K String a)
-> NS f xs
-> NS (K String) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy CondenseConstraints
pCondense (String -> K String a
forall k a (b :: k). a -> K a b
K (String -> K String a) -> (f a -> String) -> f a -> K String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> String
forall a. Condense a => a -> String
condense)

{-------------------------------------------------------------------------------
  Instances
-------------------------------------------------------------------------------}

instance All CondenseConstraints xs => Condense (HardForkBlock xs) where
  condense :: HardForkBlock xs -> String
condense = Proxy I -> NS I xs -> String
forall (xs :: [*]) (f :: * -> *).
(All CondenseConstraints xs,
 forall blk. CondenseConstraints blk => Condense (f blk)) =>
Proxy f -> NS f xs -> String
defaultCondenseNS (Proxy I
forall k (t :: k). Proxy t
Proxy @I) (NS I xs -> String)
-> (HardForkBlock xs -> NS I xs) -> HardForkBlock xs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkBlock xs -> NS I xs
coerce

instance All CondenseConstraints xs => Condense (Header (HardForkBlock xs)) where
  condense :: Header (HardForkBlock xs) -> String
condense = Proxy Header -> NS Header xs -> String
forall (xs :: [*]) (f :: * -> *).
(All CondenseConstraints xs,
 forall blk. CondenseConstraints blk => Condense (f blk)) =>
Proxy f -> NS f xs -> String
defaultCondenseNS (Proxy Header
forall k (t :: k). Proxy t
Proxy @Header) (NS Header xs -> String)
-> (Header (HardForkBlock xs) -> NS Header xs)
-> Header (HardForkBlock xs)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (HardForkBlock xs) -> NS Header xs
coerce

instance All CondenseConstraints xs => Condense (GenTx (HardForkBlock xs)) where
  condense :: GenTx (HardForkBlock xs) -> String
condense = Proxy GenTx -> NS GenTx xs -> String
forall (xs :: [*]) (f :: * -> *).
(All CondenseConstraints xs,
 forall blk. CondenseConstraints blk => Condense (f blk)) =>
Proxy f -> NS f xs -> String
defaultCondenseNS (Proxy GenTx
forall k (t :: k). Proxy t
Proxy @GenTx) (NS GenTx xs -> String)
-> (GenTx (HardForkBlock xs) -> NS GenTx xs)
-> GenTx (HardForkBlock xs)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (HardForkBlock xs) -> NS GenTx xs
coerce

instance All CondenseConstraints xs => Condense (TxId (GenTx (HardForkBlock xs))) where
  condense :: TxId (GenTx (HardForkBlock xs)) -> String
condense = Proxy WrapGenTxId -> NS WrapGenTxId xs -> String
forall (xs :: [*]) (f :: * -> *).
(All CondenseConstraints xs,
 forall blk. CondenseConstraints blk => Condense (f blk)) =>
Proxy f -> NS f xs -> String
defaultCondenseNS (Proxy WrapGenTxId
forall k (t :: k). Proxy t
Proxy @WrapGenTxId) (NS WrapGenTxId xs -> String)
-> (TxId (GenTx (HardForkBlock xs)) -> NS WrapGenTxId xs)
-> TxId (GenTx (HardForkBlock xs))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId (GenTx (HardForkBlock xs)) -> NS WrapGenTxId xs
coerce

{-------------------------------------------------------------------------------
  Forwarding
-------------------------------------------------------------------------------}

instance Condense a => Condense (I a) where
  condense :: I a -> String
condense = a -> String
forall a. Condense a => a -> String
condense (a -> String) -> (I a -> a) -> I a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I a -> a
forall a. I a -> a
unI

instance Condense (GenTxId blk) => Condense (WrapGenTxId blk) where
  condense :: WrapGenTxId blk -> String
condense = GenTxId blk -> String
forall a. Condense a => a -> String
condense (GenTxId blk -> String)
-> (WrapGenTxId blk -> GenTxId blk) -> WrapGenTxId blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapGenTxId blk -> GenTxId blk
forall blk. WrapGenTxId blk -> GenTxId blk
unwrapGenTxId