{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Util.Orphans () where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Binary.FixedSizeCodec (decodeFixedSized, encodeFixedSized)
import Cardano.Crypto.DSIGN.Class
import Cardano.Crypto.DSIGN.Mock (MockDSIGN)
import Cardano.Crypto.Hash (Hash, HashAlgorithm)
import Cardano.Ledger.BaseTypes (Nonce, shelleyProtVer)
import Cardano.Ledger.Binary
  ( DecCBOR (..)
  , EncCBOR (..)
  , toPlainDecoder
  , toPlainEncoding
  )
import Cardano.Ledger.Genesis (NoGenesis (..))
import Codec.CBOR.Decoding (Decoder)
import Codec.Serialise (Serialise (..))
import Control.Tracer (Tracer)
import Data.Array (Array)
import qualified Data.Array as Array
import Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as PSQ
import Data.Map.NonEmpty (NEMap)
import qualified Data.Map.NonEmpty as NEMap
import Data.MultiSet (MultiSet)
import qualified Data.MultiSet as MultiSet
import Data.SOP.BasicFunctors
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NESet
import Data.Typeable (Typeable)
import Data.Void (Void)
import NoThunks.Class
  ( InspectHeapNamed (..)
  , NoThunks (..)
  , OnlyCheckWhnf (..)
  , OnlyCheckWhnfNamed (..)
  , allNoThunks
  )
import Ouroboros.Network.Util.ShowProxy
import System.FS.API (SomeHasFS)
import System.FS.API.Types (Handle)
import System.FS.CRC (CRC (CRC))
import System.Random (StdGen)
import qualified System.Random.Internal as Random

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

instance (HashAlgorithm h, Typeable a) => Serialise (Hash h a) where
  encode :: Hash h a -> Encoding
encode = Hash h a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  decode :: forall s. Decoder s (Hash h a)
decode = Decoder s (Hash h a)
forall s. Decoder s (Hash h a)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Serialise (VerKeyDSIGN MockDSIGN) where
  encode :: VerKeyDSIGN MockDSIGN -> Encoding
encode = VerKeyDSIGN MockDSIGN -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized
  decode :: forall s. Decoder s (VerKeyDSIGN MockDSIGN)
decode = Decoder s (VerKeyDSIGN MockDSIGN)
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized

{-------------------------------------------------------------------------------
  FromCBOR / ToCBOR
-------------------------------------------------------------------------------}

instance FromCBOR Nonce where
  fromCBOR :: forall s. Decoder s Nonce
fromCBOR = Maybe ByteString -> Version -> Decoder s Nonce -> Decoder s Nonce
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder Maybe ByteString
forall a. Maybe a
Nothing Version
shelleyProtVer Decoder s Nonce
forall s. Decoder s Nonce
forall a s. DecCBOR a => Decoder s a
decCBOR

instance ToCBOR Nonce where
  toCBOR :: Nonce -> Encoding
toCBOR = Version -> Encoding -> Encoding
toPlainEncoding Version
shelleyProtVer (Encoding -> Encoding) -> (Nonce -> Encoding) -> Nonce -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nonce -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR

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

instance NoThunks (NoGenesis era) where
  showTypeOf :: Proxy (NoGenesis era) -> String
showTypeOf Proxy (NoGenesis era)
_ = String
"NoGenesis"
  wNoThunks :: Context -> NoGenesis era -> IO (Maybe ThunkInfo)
wNoThunks Context
_ NoGenesis era
NoGenesis = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ThunkInfo
forall a. Maybe a
Nothing

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)

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 (forall t. Proxy t
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

instance NoThunks a => NoThunks (MultiSet a) where
  showTypeOf :: Proxy (MultiSet a) -> String
showTypeOf Proxy (MultiSet a)
_ = String
"MultiSet"
  wNoThunks :: Context -> MultiSet a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> Map a Int -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (Map a Int -> IO (Maybe ThunkInfo))
-> (MultiSet a -> Map a Int) -> MultiSet a -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiSet a -> Map a Int
forall a. MultiSet a -> Map a Int
MultiSet.toMap

instance (NoThunks k, NoThunks v) => NoThunks (NEMap k v) where
  showTypeOf :: Proxy (NEMap k v) -> String
showTypeOf Proxy (NEMap k v)
_ = String
"NEMap"
  wNoThunks :: Context -> NEMap k v -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> Map k v -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (Map k v -> IO (Maybe ThunkInfo))
-> (NEMap k v -> Map k v) -> NEMap k v -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NEMap k v -> Map k v
forall k a. NEMap k a -> Map k a
NEMap.toMap

instance NoThunks v => NoThunks (NESet v) where
  showTypeOf :: Proxy (NESet v) -> String
showTypeOf Proxy (NESet v)
_ = String
"NESet"
  wNoThunks :: Context -> NESet v -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> Set v -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt (Set v -> IO (Maybe ThunkInfo))
-> (NESet v -> Set v) -> NESet v -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESet v -> Set v
forall a. NESet a -> Set a
NESet.toSet

instance NoThunks a => NoThunks (Array i a) where
  showTypeOf :: Proxy (Array i a) -> String
showTypeOf Proxy (Array i a)
_ = String
"Array"
  wNoThunks :: Context -> Array i a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> [a] -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt ([a] -> IO (Maybe ThunkInfo))
-> (Array i a -> [a]) -> Array i a -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array i a -> [a]
forall i e. Array i e -> [e]
Array.elems

instance NoThunks StdGen where
  showTypeOf :: Proxy StdGen -> String
showTypeOf Proxy StdGen
_ = String
"StdGen"
  wNoThunks :: Context -> StdGen -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx = Context -> OnlyCheckWhnf SMGen -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (OnlyCheckWhnf SMGen -> IO (Maybe ThunkInfo))
-> (StdGen -> OnlyCheckWhnf SMGen)
-> StdGen
-> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMGen -> OnlyCheckWhnf SMGen
forall a. a -> OnlyCheckWhnf a
OnlyCheckWhnf (SMGen -> OnlyCheckWhnf SMGen)
-> (StdGen -> SMGen) -> StdGen -> OnlyCheckWhnf SMGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdGen -> SMGen
Random.unStdGen

{-------------------------------------------------------------------------------
  fs-api
-------------------------------------------------------------------------------}

deriving newtype instance NoThunks CRC
deriving via
  InspectHeapNamed "Handle" (Handle h)
  instance
    NoThunks (Handle h)
deriving via
  OnlyCheckWhnfNamed "SomeHasFS" (SomeHasFS m)
  instance
    NoThunks (SomeHasFS m)

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

instance ShowProxy Void
instance ShowProxy ()