{-# LANGUAGE NumericUnderscores #-}

module Cardano.Logging.Utils
       ( module Cardano.Logging.Utils )
       where


import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async (concurrently_)
import           Control.Exception (SomeAsyncException (..), SomeException, fromException, tryJust)
import           Data.IORef
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL (toStrict)
import qualified Data.Text.Lazy.Builder as T (toLazyText)
import qualified Data.Text.Lazy.Builder.Int as T
import qualified Data.Text.Lazy.Builder.RealFloat as T (realFloat)
import           GHC.Conc (labelThread, myThreadId)


-- | Run an IO action which may throw an exception in a loop.
--   On exception, the action will be re-run after a pause.
--   That pause doubles which each exception, but is reset when the action runs long enough.
runInLoop :: IO () -> (SomeException -> IO ()) -> Word -> Word -> IO ()
runInLoop :: IO () -> (SomeException -> IO ()) -> Word -> Word -> IO ()
runInLoop IO ()
action SomeException -> IO ()
handleInterruption Word
initialDelay Word
maxDelay
  | Word
initialDelay Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0         = IO () -> (SomeException -> IO ()) -> Word -> Word -> IO ()
runInLoop IO ()
action SomeException -> IO ()
handleInterruption Word
1 Word
maxDelay
  | Word
maxDelay Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
initialDelay   = IO () -> (SomeException -> IO ()) -> Word -> Word -> IO ()
runInLoop IO ()
action SomeException -> IO ()
handleInterruption Word
initialDelay Word
initialDelay
  | Bool
otherwise                 = Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
initialDelay) IO (IORef Int) -> (IORef Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Int -> IO ()
go
  where
    go :: IORef Int -> IO ()
    go :: IORef Int -> IO ()
go IORef Int
currentDelay =
      (SomeException -> Maybe SomeException)
-> IO () -> IO (Either SomeException ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust SomeException -> Maybe SomeException
excludeAsyncExceptions (IORef Int -> IO ()
forall {a}. Num a => IORef a -> IO ()
actionResettingDelay IORef Int
currentDelay) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
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 SomeException
e -> do
          SomeException -> IO ()
handleInterruption SomeException
e
          Int
waitForSecs <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
currentDelay Int -> (Int, Int)
forall {b}. (Ord b, Num b) => b -> (b, b)
bumpDelay
          Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
1_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
waitForSecs
          IORef Int -> IO ()
go IORef Int
currentDelay
        Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- if the action runs at least maxDelay seconds, the pause is reset
    actionResettingDelay :: IORef a -> IO ()
actionResettingDelay IORef a
currentDelay = IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
action (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Word
1_000_000 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
maxDelay
      IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef a
currentDelay (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ Word -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
initialDelay

    excludeAsyncExceptions :: SomeException -> Maybe SomeException
excludeAsyncExceptions SomeException
e =
      case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just SomeAsyncException{} -> Maybe SomeException
forall a. Maybe a
Nothing
        Maybe SomeAsyncException
_ -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e

    bumpDelay :: b -> (b, b)
bumpDelay b
current =
      ( b -> b -> b
forall a. Ord a => a -> a -> a
min (b
current b -> b -> b
forall a. Num a => a -> a -> a
* b
2) (Word -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
maxDelay)
      , b
current
      )


-- | Convenience function for a Show instance to be converted to text immediately
{-# INLINE showT #-}
showT :: Show a => a -> T.Text
showT :: forall a. Show a => a -> Text
showT = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

{-# INLINE showTHex #-}
showTHex :: Integral a => a -> T.Text
showTHex :: forall a. Integral a => a -> Text
showTHex = Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
T.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Integral a => a -> Builder
T.hexadecimal

{-# INLINE showTReal #-}
showTReal :: RealFloat a => a -> T.Text
showTReal :: forall a. RealFloat a => a -> Text
showTReal = Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
T.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. RealFloat a => a -> Builder
T.realFloat

threadLabelMe :: String -> IO ()
threadLabelMe :: String -> IO ()
threadLabelMe String
label = IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ThreadId -> String -> IO ()) -> String -> ThreadId -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> String -> IO ()
labelThread String
label