-- NOTE: Usage of 'trace' in 'spy' is accepted here.
{-# OPTIONS_GHC -Wno-deprecations #-}
-- NOTE: For the 'NominalDiffTime' CBOR instances below.
{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Prelude (
  module Relude,
  MonadLabelledSTM,
  MonadSTM,
  STM,
  atomically,
  module Control.Monad.Class.MonadTime.SI,
  module Control.Monad.Class.MonadST,
  MonadAsync,
  Async,
  module Control.Monad.Class.MonadEventlog,
  module Control.Monad.Class.MonadTimer.SI,
  Control.Monad.Class.MonadFork.MonadFork,
  Control.Monad.Class.MonadFork.MonadThread,
  Control.Monad.Class.MonadFork.myThreadId,
  labelThisThread,
  module Control.Monad.Class.MonadThrow,
  module Control.Concurrent.Class.MonadSTM.TBQueue,
  module Control.Concurrent.Class.MonadSTM.TMVar,
  module Control.Concurrent.Class.MonadSTM.TQueue,
  module Control.Concurrent.Class.MonadSTM.TVar,
  StaticMap (..),
  DynamicMap (..),
  keys,
  elems,
  FromCBOR (..),
  ToCBOR (..),
  genericToCBOR,
  genericFromCBOR,
  FromJSON (..),
  ToJSON (..),
  encodePretty,
  padRight,
  Except,
  encodeBase16,
  decodeBase16,
  (?>),
  withFile,
  spy,
  spy',
  newLabelledTVar,
  newLabelledTVarIO,
  newLabelledEmptyTMVar,
  newLabelledTQueueIO,
  newLabelledEmptyTMVarIO,
  concurrentlyLabelled,
  concurrentlyLabelled_,
  asyncLabelled,
  raceLabelled,
  raceLabelled_,
  withAsyncLabelled,
  newLabelledTQueue,
  newLabelledTBQueue,
  newLabelledTBQueueIO,
) where

import Cardano.Binary (
  FromCBOR (..),
  ToCBOR (..),
 )
import Codec.CBOR.Generic.Tagged (genericFromCBOR, genericToCBOR)
import Control.Concurrent.Class.Labelled
import Control.Concurrent.Class.MonadSTM (MonadLabelledSTM (..), MonadSTM (..))
import Control.Concurrent.Class.MonadSTM.TBQueue (TBQueue)
import Control.Concurrent.Class.MonadSTM.TMVar (TMVar)
import Control.Concurrent.Class.MonadSTM.TQueue (TQueue)
import Control.Concurrent.Class.MonadSTM.TVar (TVar, readTVar)
import Control.Exception (IOException)
import Control.Monad.Class.MonadAsync (
  Async,
  MonadAsync,
 )
import Control.Monad.Class.MonadEventlog (
  MonadEventlog,
 )
import Control.Monad.Class.MonadFork (MonadFork, MonadThread, labelThisThread, myThreadId)
import Control.Monad.Class.MonadST (
  MonadST,
 )
import Control.Monad.Class.MonadSTM ()
import Control.Monad.Class.MonadThrow (
  MonadCatch (..),
  MonadEvaluate (..),
  MonadMask (..),
  MonadThrow (..),
 )
import Control.Monad.Class.MonadTime.SI (
  DiffTime,
  MonadMonotonicTime (..),
  MonadTime (..),
  NominalDiffTime,
  Time (..),
  UTCTime,
  addTime,
  addUTCTime,
  diffTime,
  diffUTCTime,
 )
import Control.Monad.Class.MonadTimer.SI (
  MonadDelay (..),
  MonadTimer (..),
 )
import Control.Monad.Trans.Except (Except)
import Data.Aeson (
  FromJSON (..),
  ToJSON (..),
 )
import Data.Aeson.Encode.Pretty (
  encodePretty,
 )
import Data.ByteString.Base16 qualified as Base16
import Data.Fixed (Fixed (..))
import Data.Text qualified as T
import Data.Time.Clock (nominalDiffTimeToSeconds, secondsToNominalDiffTime)
import Relude hiding (
  MVar,
  Nat,
  STM,
  TMVar,
  TVar,
  atomically,
  catchSTM,
  isEmptyTMVar,
  mkWeakTMVar,
  modifyTVar',
  newEmptyMVar,
  newEmptyTMVar,
  newEmptyTMVarIO,
  newMVar,
  newTMVar,
  newTMVarIO,
  newTVar,
  newTVarIO,
  putMVar,
  putTMVar,
  readMVar,
  readTMVar,
  readTVar,
  readTVarIO,
  swapMVar,
  swapTMVar,
  takeMVar,
  takeTMVar,
  throwSTM,
  traceM,
  tryPutMVar,
  tryPutTMVar,
  tryReadMVar,
  tryReadTMVar,
  tryTakeMVar,
  tryTakeTMVar,
  withFile,
  writeTVar,
 )
import Relude.Extra.Map (
  DynamicMap (..),
  StaticMap (..),
  elems,
  keys,
 )
import System.IO qualified
import Text.Pretty.Simple (pShow)

-- Orphan CBOR instances: cardano-binary provides 'UTCTime' instances, but
-- lacks 'NominalDiffTime'. Encoded as integer picoseconds, which is lossless
-- since 'NominalDiffTime' has fixed picosecond resolution.
instance ToCBOR NominalDiffTime where
  toCBOR :: NominalDiffTime -> Encoding
toCBOR NominalDiffTime
ndt = case NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
ndt of MkFixed Integer
i -> Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Integer
i

instance FromCBOR NominalDiffTime where
  fromCBOR :: forall s. Decoder s NominalDiffTime
fromCBOR = Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (Integer -> Pico) -> Integer -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Pico
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> NominalDiffTime)
-> Decoder s Integer -> Decoder s NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Pad a text-string to right with the given character until it reaches the given
-- length.
--
-- NOTE: Truncate the string if longer than the given length.
padRight :: Char -> Int -> Text -> Text
padRight :: Char -> Int -> Text -> Text
padRight Char
c Int
n Text
str = Int -> Text -> Text
T.take Int
n (Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n (Char -> Text
T.singleton Char
c))

-- | Encode some bytes to hex-encoded text.
--
-- >>> encodeBase16 "ab"
-- "4142"
encodeBase16 :: ByteString -> Text
encodeBase16 :: ByteString -> Text
encodeBase16 =
  ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode

-- | Decode some hex-encoded text string to raw bytes.
--
-- >>> decodeBase16 "dflkgjdjgdh"
-- Left "Not base 16"
decodeBase16 :: MonadFail f => Text -> f ByteString
decodeBase16 :: forall (f :: * -> *). MonadFail f => Text -> f ByteString
decodeBase16 =
  (String -> f ByteString)
-> (ByteString -> f ByteString)
-> Either String ByteString
-> f ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> f ByteString
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> f ByteString
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> f ByteString)
-> (Text -> Either String ByteString) -> Text -> f ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

infixl 4 ?>

-- | If 'Nothing' use given 'e' as 'Left'. Infix version of `maybeToEither`.
(?>) :: Maybe a -> e -> Either e a
?> :: forall a e. Maybe a -> e -> Either e a
(?>) Maybe a
m e
e =
  case Maybe a
m of
    Maybe a
Nothing -> e -> Either e a
forall a b. a -> Either a b
Left e
e
    Just a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a

-- | Like 'withFile' from 'base', but without annotating errors originating from
-- enclosed action.
--
-- XXX: This should be fixed upstream in 'base'.
withFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a
withFile :: forall a. String -> IOMode -> (Handle -> IO a) -> IO a
withFile String
fp IOMode
mode Handle -> IO a
action =
  String
-> IOMode
-> (Handle -> IO (Either IOException a))
-> IO (Either IOException a)
forall a. String -> IOMode -> (Handle -> IO a) -> IO a
System.IO.withFile String
fp IOMode
mode (IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO a -> IO (Either IOException a))
-> (Handle -> IO a) -> Handle -> IO (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO a
action) IO (Either IOException a) -> (Either IOException a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (IOException
e :: IOException) -> IOException -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
    Right a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Like 'traceShow', but with pretty printing of the value.
{-# WARNING spy "Use for debugging purposes only" #-}
spy :: Show a => a -> a
spy :: forall a. Show a => a -> a
spy a
a = String -> a -> a
forall a. String -> a -> a
trace (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. Show a => a -> Text
pShow a
a) a
a

-- | Like 'spy' but prefixed with a label.
{-# WARNING spy' "Use for debugging purposes only" #-}
spy' :: Show a => String -> a -> a
spy' :: forall a. Show a => String -> a -> a
spy' String
msg a
a = String -> a -> a
forall a. String -> a -> a
trace (String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (a -> Text
forall a. Show a => a -> Text
pShow a
a)) a
a

-- Labelled STM/async helpers now live in the io-classes-labelled package and
-- are re-exported here (see the import of Control.Concurrent.Class.Labelled).