{-# LANGUAGE UndecidableInstances #-}

-- | Provides the 'Timeout' type.
module Shrun.Configuration.Data.Core.Timeout
  ( Timeout (..),
    parseTimeout,
    parseTimeoutStr,
    timeoutMeta,
  )
where

import Data.Time.Relative qualified as RT
import Shrun.Configuration.Data.WithDisabled (WithDisabled (Disabled))
import Shrun.Configuration.Default (Default (def))
import Shrun.Prelude
import Shrun.Utils qualified as Utils

-- | Represents a timeout, which is a non-negative integer.
newtype Timeout = MkTimeout
  { Timeout -> Natural
unTimeout :: Natural
  }
  deriving stock (Timeout -> Timeout -> Bool
(Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool) -> Eq Timeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
/= :: Timeout -> Timeout -> Bool
Eq, Eq Timeout
Eq Timeout =>
(Timeout -> Timeout -> Ordering)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Timeout)
-> (Timeout -> Timeout -> Timeout)
-> Ord Timeout
Timeout -> Timeout -> Bool
Timeout -> Timeout -> Ordering
Timeout -> Timeout -> Timeout
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Timeout -> Timeout -> Ordering
compare :: Timeout -> Timeout -> Ordering
$c< :: Timeout -> Timeout -> Bool
< :: Timeout -> Timeout -> Bool
$c<= :: Timeout -> Timeout -> Bool
<= :: Timeout -> Timeout -> Bool
$c> :: Timeout -> Timeout -> Bool
> :: Timeout -> Timeout -> Bool
$c>= :: Timeout -> Timeout -> Bool
>= :: Timeout -> Timeout -> Bool
$cmax :: Timeout -> Timeout -> Timeout
max :: Timeout -> Timeout -> Timeout
$cmin :: Timeout -> Timeout -> Timeout
min :: Timeout -> Timeout -> Timeout
Ord, Int -> Timeout -> ShowS
[Timeout] -> ShowS
Timeout -> String
(Int -> Timeout -> ShowS)
-> (Timeout -> String) -> ([Timeout] -> ShowS) -> Show Timeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Timeout -> ShowS
showsPrec :: Int -> Timeout -> ShowS
$cshow :: Timeout -> String
show :: Timeout -> String
$cshowList :: [Timeout] -> ShowS
showList :: [Timeout] -> ShowS
Show)
  deriving (HasCallStack => Integer -> Timeout
(HasCallStack => Integer -> Timeout) -> FromInteger Timeout
forall a. (HasCallStack => Integer -> a) -> FromInteger a
$cfromZ :: HasCallStack => Integer -> Timeout
fromZ :: HasCallStack => Integer -> Timeout
FromInteger, Integer -> Timeout
Timeout -> Timeout
Timeout -> Timeout -> Timeout
(Timeout -> Timeout -> Timeout)
-> (Timeout -> Timeout -> Timeout)
-> (Timeout -> Timeout -> Timeout)
-> (Timeout -> Timeout)
-> (Timeout -> Timeout)
-> (Timeout -> Timeout)
-> (Integer -> Timeout)
-> Num Timeout
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Timeout -> Timeout -> Timeout
+ :: Timeout -> Timeout -> Timeout
$c- :: Timeout -> Timeout -> Timeout
- :: Timeout -> Timeout -> Timeout
$c* :: Timeout -> Timeout -> Timeout
* :: Timeout -> Timeout -> Timeout
$cnegate :: Timeout -> Timeout
negate :: Timeout -> Timeout
$cabs :: Timeout -> Timeout
abs :: Timeout -> Timeout
$csignum :: Timeout -> Timeout
signum :: Timeout -> Timeout
$cfromInteger :: Integer -> Timeout
fromInteger :: Integer -> Timeout
Num, (forall ann. Timeout -> Doc ann)
-> (forall ann. [Timeout] -> Doc ann) -> Pretty Timeout
forall ann. [Timeout] -> Doc ann
forall ann. Timeout -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Timeout -> Doc ann
pretty :: forall ann. Timeout -> Doc ann
$cprettyList :: forall ann. [Timeout] -> Doc ann
prettyList :: forall ann. [Timeout] -> Doc ann
Pretty) via Natural

instance
  (k ~ An_Iso, a ~ Natural, b ~ Natural) =>
  LabelOptic "unTimeout" k Timeout Timeout a b
  where
  labelOptic :: Optic k NoIx Timeout Timeout a b
labelOptic = (Timeout -> a) -> (b -> Timeout) -> Iso Timeout Timeout a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(MkTimeout Natural
x) -> a
Natural
x) b -> Timeout
Natural -> Timeout
MkTimeout
  {-# INLINE labelOptic #-}

instance DecodeTOML Timeout where
  tomlDecoder :: Decoder Timeout
tomlDecoder = Decoder Natural -> Decoder Text -> Decoder Timeout
forall (f :: Type -> Type).
(Alternative f, MonadFail f) =>
f Natural -> f Text -> f Timeout
parseTimeout Decoder Natural
forall a. DecodeTOML a => Decoder a
tomlDecoder Decoder Text
forall a. DecodeTOML a => Decoder a
tomlDecoder

instance Default (WithDisabled Timeout) where
  def :: WithDisabled Timeout
def = WithDisabled Timeout
forall a. WithDisabled a
Disabled

-- NOTE: [CLI vs. Toml Types]
--
-- Normally we'd want CLI and Toml to share the exact same parsing, however,
-- we should take advantage of Toml's types when possible. For instance,
-- here we want to allow parsing a numeric nat or a "time string".
--
-- The CLI has to make do with strings everywhere, hence parseTimeout makes sense.

parseTimeout :: (Alternative f, MonadFail f) => f Natural -> f Text -> f Timeout
parseTimeout :: forall (f :: Type -> Type).
(Alternative f, MonadFail f) =>
f Natural -> f Text -> f Timeout
parseTimeout f Natural
getNat f Text
getTxt =
  (Natural -> Timeout
MkTimeout (Natural -> Timeout) -> f Natural -> f Timeout
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> f Natural
getNat) f Timeout -> f Timeout -> f Timeout
forall a. f a -> f a -> f a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (f Text
getTxt f Text -> (Text -> f Timeout) -> f Timeout
forall a b. f a -> (a -> f b) -> f b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> f Timeout
forall (f :: Type -> Type). MonadFail f => Text -> f Timeout
parseTimeoutStr)
{-# INLINEABLE parseTimeout #-}

parseTimeoutStr :: (MonadFail f) => Text -> f Timeout
parseTimeoutStr :: forall (f :: Type -> Type). MonadFail f => Text -> f Timeout
parseTimeoutStr Text
txt = case String -> Either String RelativeTime
RT.fromString String
str of
  Right RelativeTime
n -> Timeout -> f Timeout
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Timeout -> f Timeout) -> Timeout -> f Timeout
forall a b. (a -> b) -> a -> b
$ Natural -> Timeout
MkTimeout (Natural -> Timeout) -> Natural -> Timeout
forall a b. (a -> b) -> a -> b
$ RelativeTime -> Natural
RT.toSeconds RelativeTime
n
  Left String
bad ->
    String -> f Timeout
forall a. String -> f a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
      (String -> f Timeout) -> String -> f Timeout
forall a b. (a -> b) -> a -> b
$ String -> (Bool, [String]) -> ShowS
forall a. (IsString a, Monoid a) => a -> (Bool, [a]) -> a -> a
Utils.fmtUnrecognizedError
        String
"timeout"
        (Bool, [String])
forall a. IsString a => (Bool, [a])
timeoutMeta
        String
bad
  where
    str :: String
str = Text -> String
unpack Text
txt
{-# INLINEABLE parseTimeoutStr #-}

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