{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications #-}
{-# 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.Proxy
import           Data.SOP.BasicFunctors
import           Data.SOP.Constraint
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 :: forall (xs :: [*]) (f :: * -> *).
(All CondenseConstraints xs,
 forall blk. CondenseConstraints blk => Condense (f blk)) =>
Proxy f -> NS f xs -> String
defaultCondenseNS Proxy f
_ = NS (K String) xs -> String
NS (K String) xs -> CollapseTo NS String
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 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> *). 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
forall a b. Coercible a b => a -> b
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 (forall {k} (t :: k). Proxy t
forall (t :: * -> *). 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
forall a b. Coercible a b => a -> b
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 (forall {k} (t :: k). Proxy t
forall (t :: * -> *). 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
forall a b. Coercible a b => a -> b
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 (forall {k} (t :: k). Proxy t
forall (t :: * -> *). 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
forall a b. Coercible a b => a -> b
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