{-# LANGUAGE UndecidableInstances #-}

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

import Data.Time.Relative qualified as RT
import Shrun.Prelude

-- | 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 (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) 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

-- 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)

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
err -> 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
"Error reading time string: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
  where
    str :: String
str = Text -> String
unpack Text
txt