-- | Provides type for notifications.
module Shrun.Configuration.Data.Notify.Timeout
  ( parseNotifyTimeout,
    notifyTimeoutMeta,
    notifyTimeoutDecoder,
    prettyNotifyTimeout,
  )
where

import Data.Bits (toIntegralSized)
import Data.Time.Relative qualified as RT
import Shrun.Prelude
import Shrun.Utils qualified as U
import Shrun.Utils qualified as Utils
import TOML (Value (Integer, String))

-- DecodeTOML instance does not reuse parseNotifyTimeout as we want to
-- enforce the integer type.

notifyTimeoutDecoder :: Decoder NotifyTimeout
notifyTimeoutDecoder :: Decoder NotifyTimeout
notifyTimeoutDecoder = (Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout
forall a. (Value -> DecodeM a) -> Decoder a
makeDecoder ((Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout)
-> (Value -> DecodeM NotifyTimeout) -> Decoder NotifyTimeout
forall a b. (a -> b) -> a -> b
$ \case
  String Text
t -> Text -> DecodeM NotifyTimeout
forall (f :: Type -> Type). MonadFail f => Text -> f NotifyTimeout
parseNotifyTimeoutStr Text
t
  Integer Integer
i -> case Integer -> Maybe Int
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized Integer
i of
    Just Int
i' -> NotifyTimeout -> DecodeM NotifyTimeout
forall a. a -> DecodeM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NotifyTimeout -> DecodeM NotifyTimeout)
-> NotifyTimeout -> DecodeM NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Int -> NotifyTimeout
NotifyTimeoutMillis (Int -> NotifyTimeout) -> Int -> NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000
    Maybe Int
Nothing -> Text -> Value -> DecodeM NotifyTimeout
forall a. Text -> Value -> DecodeM a
invalidValue (Maybe Integer -> Text
tooLargeErr Maybe Integer
forall a. Maybe a
Nothing) (Integer -> Value
Integer Integer
i)
  Value
badTy -> Value -> DecodeM NotifyTimeout
forall a. Value -> DecodeM a
typeMismatch Value
badTy

prettyNotifyTimeout :: NotifyTimeout -> Doc ann
prettyNotifyTimeout :: forall ann. NotifyTimeout -> Doc ann
prettyNotifyTimeout = \case
  NotifyTimeout
NotifyTimeoutNever -> Doc ann
"off"
  NotifyTimeoutMillis Int
x -> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Doc ann) -> Int -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1_000

tooLargeErr :: Maybe Integer -> Text
tooLargeErr :: Maybe Integer -> Text
tooLargeErr Maybe Integer
Nothing = Text
"Timeout integer too large. Max is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
showt Word16
maxW16
tooLargeErr (Just Integer
i) =
  [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Timeout integer '",
      Integer -> Text
forall a. Show a => a -> Text
showt Integer
i,
      Text
"' too large. Max is: ",
      Word16 -> Text
forall a. Show a => a -> Text
showt Word16
maxW16
    ]

maxW16 :: Word16
maxW16 :: Word16
maxW16 = Word16
forall a. Bounded a => a
maxBound

-- | Parses 'NotifyTimeout'. For CLI only.
parseNotifyTimeout :: (MonadFail m) => m Text -> m NotifyTimeout
parseNotifyTimeout :: forall (m :: Type -> Type).
MonadFail m =>
m Text -> m NotifyTimeout
parseNotifyTimeout m Text
getTxt = do
  Text
txt <- m Text
getTxt
  case forall (m :: Type -> Type) a. (MonadFail m, Read a) => Text -> m a
U.readStripUnderscores @_ @Natural Text
txt of
    Just Natural
nNat -> NotifyTimeout -> m NotifyTimeout
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NotifyTimeout -> m NotifyTimeout)
-> NotifyTimeout -> m NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Int -> NotifyTimeout
NotifyTimeoutMillis (Int -> NotifyTimeout) -> Int -> NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Natural -> Int
unsafeFromNatSec Natural
nNat
    Maybe Natural
Nothing -> Text -> m NotifyTimeout
forall (f :: Type -> Type). MonadFail f => Text -> f NotifyTimeout
parseNotifyTimeoutStr Text
txt
{-# INLINEABLE parseNotifyTimeout #-}

unsafeFromNatSec :: Natural -> Int
unsafeFromNatSec :: Natural -> Int
unsafeFromNatSec = Natural -> Int
forall a b.
(Bits a, Bits b, HasCallStack, Integral a, Integral b, Show a,
 Typeable a, Typeable b) =>
a -> b
unsafeConvertIntegral (Natural -> Int) -> (Natural -> Natural) -> Natural -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
1_000)

-- | Parses a string only i.e. should either be 'off' or a time string, not
-- a literal natural. Intended for:
--
-- - CLI, after parsing a literal fails.
-- - TOML, when given a String not Integer.
parseNotifyTimeoutStr :: (MonadFail f) => Text -> f NotifyTimeout
parseNotifyTimeoutStr :: forall (f :: Type -> Type). MonadFail f => Text -> f NotifyTimeout
parseNotifyTimeoutStr Text
"off" = NotifyTimeout -> f NotifyTimeout
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NotifyTimeout
NotifyTimeoutNever
parseNotifyTimeoutStr Text
txt = case String -> Either String RelativeTime
RT.fromString String
str of
  Right RelativeTime
n -> NotifyTimeout -> f NotifyTimeout
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NotifyTimeout -> f NotifyTimeout)
-> NotifyTimeout -> f NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Int -> NotifyTimeout
NotifyTimeoutMillis (Int -> NotifyTimeout) -> Int -> NotifyTimeout
forall a b. (a -> b) -> a -> b
$ Natural -> Int
unsafeFromNatSec (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ RelativeTime -> Natural
RT.toSeconds RelativeTime
n
  Left String
bad ->
    String -> f NotifyTimeout
forall a. String -> f a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
      (String -> f NotifyTimeout) -> String -> f NotifyTimeout
forall a b. (a -> b) -> a -> b
$ String -> (Bool, [String]) -> String -> String
forall a. (IsString a, Monoid a) => a -> (Bool, [a]) -> a -> a
Utils.fmtUnrecognizedError
        String
"notify timeout"
        (Bool, [String])
forall a. IsString a => (Bool, [a])
notifyTimeoutMeta
        String
bad
  where
    str :: String
str = Text -> String
unpack Text
txt
{-# INLINEABLE parseNotifyTimeoutStr #-}

notifyTimeoutMeta :: (IsString a) => Tuple2 Bool (List a)
notifyTimeoutMeta :: forall a. IsString a => (Bool, [a])
notifyTimeoutMeta = (Bool
True, [a
"NATURAL", a
"TIME_STR"])