{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE UndecidableInstances       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Util.Orphans () where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.Serialise (Serialise (..))
import           Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import           Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as PSQ
import           Data.SOP.Strict
import           NoThunks.Class (NoThunks (..), OnlyCheckWhnfNamed (..),
                     allNoThunks, noThunksInKeysAndValues)

import           Control.Tracer (Tracer)

import           Control.Monad.Class.MonadTime (Time (..))

import           Ouroboros.Consensus.Util.MonadSTM.NormalForm

import           Cardano.Crypto.DSIGN.Class
import           Cardano.Crypto.DSIGN.Mock (MockDSIGN)
import           Cardano.Crypto.Hash (Hash)

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.MockChain.Chain (Chain (..))

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

{-------------------------------------------------------------------------------
  Condense
-------------------------------------------------------------------------------}

instance Condense (HeaderHash block) => Condense (Point block) where
    condense :: Point block -> String
condense Point block
GenesisPoint     = String
"Origin"
    condense (BlockPoint SlotNo
s HeaderHash block
h) = String
"(Point " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeaderHash block -> String
forall a. Condense a => a -> String
condense HeaderHash block
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

instance Condense block => Condense (Chain block) where
    condense :: Chain block -> String
condense Chain block
Genesis   = String
"Genesis"
    condense (Chain block
cs :> block
b) = Chain block -> String
forall a. Condense a => a -> String
condense Chain block
cs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> block -> String
forall a. Condense a => a -> String
condense block
b

instance (Condense block, HasHeader block, Condense (HeaderHash block))
    => Condense (AnchoredFragment block) where
    condense :: AnchoredFragment block -> String
condense (AF.Empty Anchor block
pt) = String
"EmptyAnchor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point block -> String
forall a. Condense a => a -> String
condense (Anchor block -> Point block
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor block
pt)
    condense (AnchoredFragment block
cs AF.:> block
b)  = AnchoredFragment block -> String
forall a. Condense a => a -> String
condense AnchoredFragment block
cs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> block -> String
forall a. Condense a => a -> String
condense block
b

{-------------------------------------------------------------------------------
  Serialise
-------------------------------------------------------------------------------}

instance Serialise (Hash h a) where

instance Serialise (VerKeyDSIGN MockDSIGN) where
  encode :: VerKeyDSIGN MockDSIGN -> Encoding
encode = VerKeyDSIGN MockDSIGN -> Encoding
forall v. DSIGNAlgorithm v => VerKeyDSIGN v -> Encoding
encodeVerKeyDSIGN
  decode :: Decoder s (VerKeyDSIGN MockDSIGN)
decode = Decoder s (VerKeyDSIGN MockDSIGN)
forall v s. DSIGNAlgorithm v => Decoder s (VerKeyDSIGN v)
decodeVerKeyDSIGN

{-------------------------------------------------------------------------------
  ShowProxy
-------------------------------------------------------------------------------}

instance ShowProxy SlotNo where

{-------------------------------------------------------------------------------
  NoThunks
-------------------------------------------------------------------------------}

instance NoThunks a => NoThunks (StrictTVar IO a) where
  showTypeOf :: Proxy (StrictTVar IO a) -> String
showTypeOf Proxy (StrictTVar IO a)
_ = String
"StrictTVar IO"
  wNoThunks :: Context -> StrictTVar IO a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt StrictTVar IO a
tv = do
      -- We can't use @atomically $ readTVar ..@ here, as that will lead to a
      -- "Control.Concurrent.STM.atomically was nested" exception.
      a
a <- StrictTVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar IO a
tv
      Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt a
a

instance (NoThunks k, NoThunks v)
      => NoThunks (Bimap k v) where
  wNoThunks :: Context -> Bimap k v -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> [(k, v)] -> IO (Maybe ThunkInfo)
forall k v.
(NoThunks k, NoThunks v) =>
Context -> [(k, v)] -> IO (Maybe ThunkInfo)
noThunksInKeysAndValues Context
ctxt ([(k, v)] -> IO (Maybe ThunkInfo))
-> (Bimap k v -> [(k, v)]) -> Bimap k v -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bimap k v -> [(k, v)]
forall a b. Bimap a b -> [(a, b)]
Bimap.toList

instance ( NoThunks p
         , NoThunks v
         , Ord p
         ) => NoThunks (IntPSQ p v) where
  showTypeOf :: Proxy (IntPSQ p v) -> String
showTypeOf Proxy (IntPSQ p v)
_ = String
"IntPSQ"
  wNoThunks :: Context -> IntPSQ p v -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt =
        [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks
      ([IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo))
-> (IntPSQ p v -> [IO (Maybe ThunkInfo)])
-> IntPSQ p v
-> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, p, v) -> [IO (Maybe ThunkInfo)])
-> [(Int, p, v)] -> [IO (Maybe ThunkInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
k, p
p, v
v) ->
        [ Context -> Int -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt Int
k
        , Context -> p -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt p
p
        , Context -> v -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctxt v
v])
      ([(Int, p, v)] -> [IO (Maybe ThunkInfo)])
-> (IntPSQ p v -> [(Int, p, v)])
-> IntPSQ p v
-> [IO (Maybe ThunkInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntPSQ p v -> [(Int, p, v)]
forall p v. IntPSQ p v -> [(Int, p, v)]
PSQ.toList

deriving via OnlyCheckWhnfNamed "Decoder" (Decoder s a) instance NoThunks (Decoder s a)

deriving via OnlyCheckWhnfNamed "Tracer" (Tracer m ev) instance NoThunks (Tracer m ev)

deriving newtype instance NoThunks Time

instance NoThunks a => NoThunks (K a b) where
  showTypeOf :: Proxy (K a b) -> String
showTypeOf Proxy (K a b)
_ = Proxy a -> String
forall a. NoThunks a => Proxy a -> String
showTypeOf (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
  wNoThunks :: Context -> K a b -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (K a
a) = Context -> a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks (String
"K"String -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctxt) a
a