{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Looper
  ( LooperDef (..),
    milliseconds,
    seconds,
    minutes,
    hours,
    LooperSettings (..),
    parseLooperSettings,
    mkLooperDef,
    runLoopers,
    runLoopersIgnoreOverrun,
    runLoopersRaw,
    runLooperDef,
    waitNominalDiffTime,
  )
where

import Data.Maybe
import Data.Text (Text)
import Data.Time
import GHC.Generics (Generic)
import OptEnvConf
import UnliftIO
import UnliftIO.Concurrent

-- | A looper definition
data LooperDef m = LooperDef
  { -- | The name of the looper, can be useful for logging
    forall (m :: * -> *). LooperDef m -> Text
looperDefName :: Text,
    -- | Whether this looper is enabled
    forall (m :: * -> *). LooperDef m -> Bool
looperDefEnabled :: Bool,
    -- | The time between the start of each run
    forall (m :: * -> *). LooperDef m -> NominalDiffTime
looperDefPeriod :: NominalDiffTime,
    -- | The time before the first run
    forall (m :: * -> *). LooperDef m -> NominalDiffTime
looperDefPhase :: NominalDiffTime,
    -- | The function to run
    forall (m :: * -> *). LooperDef m -> m ()
looperDefFunc :: m ()
  }
  deriving ((forall x. LooperDef m -> Rep (LooperDef m) x)
-> (forall x. Rep (LooperDef m) x -> LooperDef m)
-> Generic (LooperDef m)
forall x. Rep (LooperDef m) x -> LooperDef m
forall x. LooperDef m -> Rep (LooperDef m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (LooperDef m) x -> LooperDef m
forall (m :: * -> *) x. LooperDef m -> Rep (LooperDef m) x
$cfrom :: forall (m :: * -> *) x. LooperDef m -> Rep (LooperDef m) x
from :: forall x. LooperDef m -> Rep (LooperDef m) x
$cto :: forall (m :: * -> *) x. Rep (LooperDef m) x -> LooperDef m
to :: forall x. Rep (LooperDef m) x -> LooperDef m
Generic)

-- | Construct a 'NominalDiffTime' from a number of milliseconds
--
-- Note that scheduling can easily get in the way of accuracy at this
-- level of granularity.
milliseconds :: Double -> NominalDiffTime
milliseconds :: Double -> NominalDiffTime
milliseconds = Double -> NominalDiffTime
seconds (Double -> NominalDiffTime)
-> (Double -> Double) -> Double -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
60)

-- | Construct a 'NominalDiffTime' from a number of seconds
seconds :: Double -> NominalDiffTime
seconds :: Double -> NominalDiffTime
seconds = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | Construct a 'NominalDiffTime' from a number of minutes
minutes :: Double -> NominalDiffTime
minutes :: Double -> NominalDiffTime
minutes = Double -> NominalDiffTime
seconds (Double -> NominalDiffTime)
-> (Double -> Double) -> Double -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
60)

-- | Construct a 'NominalDiffTime' from a number of hours
hours :: Double -> NominalDiffTime
hours :: Double -> NominalDiffTime
hours = Double -> NominalDiffTime
minutes (Double -> NominalDiffTime)
-> (Double -> Double) -> Double -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
60)

-- | Settings that you might want to pass into a looper using 'mkLooperDef'
data LooperSettings = LooperSettings
  { LooperSettings -> Bool
looperSetEnabled :: Bool,
    LooperSettings -> NominalDiffTime
looperSetPhase :: NominalDiffTime,
    LooperSettings -> NominalDiffTime
looperSetPeriod :: NominalDiffTime
  }
  deriving (Int -> LooperSettings -> ShowS
[LooperSettings] -> ShowS
LooperSettings -> String
(Int -> LooperSettings -> ShowS)
-> (LooperSettings -> String)
-> ([LooperSettings] -> ShowS)
-> Show LooperSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LooperSettings -> ShowS
showsPrec :: Int -> LooperSettings -> ShowS
$cshow :: LooperSettings -> String
show :: LooperSettings -> String
$cshowList :: [LooperSettings] -> ShowS
showList :: [LooperSettings] -> ShowS
Show, LooperSettings -> LooperSettings -> Bool
(LooperSettings -> LooperSettings -> Bool)
-> (LooperSettings -> LooperSettings -> Bool) -> Eq LooperSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LooperSettings -> LooperSettings -> Bool
== :: LooperSettings -> LooperSettings -> Bool
$c/= :: LooperSettings -> LooperSettings -> Bool
/= :: LooperSettings -> LooperSettings -> Bool
Eq, (forall x. LooperSettings -> Rep LooperSettings x)
-> (forall x. Rep LooperSettings x -> LooperSettings)
-> Generic LooperSettings
forall x. Rep LooperSettings x -> LooperSettings
forall x. LooperSettings -> Rep LooperSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LooperSettings -> Rep LooperSettings x
from :: forall x. LooperSettings -> Rep LooperSettings x
$cto :: forall x. Rep LooperSettings x -> LooperSettings
to :: forall x. Rep LooperSettings x -> LooperSettings
Generic)

parseLooperSettings ::
  String ->
  NominalDiffTime ->
  NominalDiffTime ->
  Parser LooperSettings
parseLooperSettings :: String
-> NominalDiffTime -> NominalDiffTime -> Parser LooperSettings
parseLooperSettings String
looperName NominalDiffTime
defaultPhase NominalDiffTime
defaultPeriod = do
  Bool
looperSetEnabled <-
    String -> Parser Bool -> Parser Bool
forall a. String -> Parser a -> Parser a
subConfig (ShowS
toConfigCase String
looperName) (Parser Bool -> Parser Bool) -> Parser Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
      String -> Parser Bool -> Parser Bool
forall a. String -> Parser a -> Parser a
subEnv (ShowS
toEnvCase String
looperName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_") (Parser Bool -> Parser Bool) -> Parser Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
        HasCallStack => [Builder Bool] -> Parser Bool
[Builder Bool] -> Parser Bool
enableDisableSwitch
          [ String -> Builder Bool
forall a. String -> Builder a
help (String -> Builder Bool) -> String -> Builder Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"enable the", String
looperName, String
"looper"],
            Builder Bool
forall a. Builder a
option,
            String -> Builder Bool
forall a. String -> Builder a
long String
looperName,
            String -> Builder Bool
forall a. String -> Builder a
env String
"ENABLE",
            String -> Builder Bool
forall a. HasCodec a => String -> Builder a
conf String
"enable",
            Bool -> Builder Bool
forall a. Show a => a -> Builder a
value Bool
True
          ]
  (NominalDiffTime
looperSetPhase, NominalDiffTime
looperSetPeriod) <- String
-> Parser (NominalDiffTime, NominalDiffTime)
-> Parser (NominalDiffTime, NominalDiffTime)
forall a. String -> Parser a -> Parser a
subAll String
looperName (Parser (NominalDiffTime, NominalDiffTime)
 -> Parser (NominalDiffTime, NominalDiffTime))
-> Parser (NominalDiffTime, NominalDiffTime)
-> Parser (NominalDiffTime, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ do
    NominalDiffTime
ph <-
      [Builder NominalDiffTime] -> Parser NominalDiffTime
forall a. HasCallStack => [Builder a] -> Parser a
setting
        [ String -> Builder NominalDiffTime
forall a. String -> Builder a
help (String -> Builder NominalDiffTime)
-> String -> Builder NominalDiffTime
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"phase of the", String
looperName, String
"looper in seconds"],
          Reader NominalDiffTime -> Builder NominalDiffTime
forall a. Reader a -> Builder a
reader (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime)
-> Reader Integer -> Reader NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader Integer
forall a. Read a => Reader a
auto),
          Builder NominalDiffTime
forall a. Builder a
option,
          String -> Builder NominalDiffTime
forall a. HasCodec a => String -> Builder a
name String
"phase",
          String -> Builder NominalDiffTime
forall a. String -> Builder a
metavar String
"SECONDS",
          NominalDiffTime -> Builder NominalDiffTime
forall a. Show a => a -> Builder a
value NominalDiffTime
defaultPhase
        ]
    NominalDiffTime
pe <-
      [Builder NominalDiffTime] -> Parser NominalDiffTime
forall a. HasCallStack => [Builder a] -> Parser a
setting
        [ String -> Builder NominalDiffTime
forall a. String -> Builder a
help (String -> Builder NominalDiffTime)
-> String -> Builder NominalDiffTime
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"period of the", String
looperName, String
"looper in seconds"],
          Reader NominalDiffTime -> Builder NominalDiffTime
forall a. Reader a -> Builder a
reader (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime)
-> Reader Integer -> Reader NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reader Integer
forall a. Read a => Reader a
auto),
          String -> Builder NominalDiffTime
forall a. HasCodec a => String -> Builder a
name String
"period",
          String -> Builder NominalDiffTime
forall a. String -> Builder a
metavar String
"SECONDS",
          NominalDiffTime -> Builder NominalDiffTime
forall a. Show a => a -> Builder a
value NominalDiffTime
defaultPeriod
        ]
    pure (NominalDiffTime
ph, NominalDiffTime
pe)
  pure LooperSettings {Bool
NominalDiffTime
looperSetEnabled :: Bool
looperSetPhase :: NominalDiffTime
looperSetPeriod :: NominalDiffTime
looperSetEnabled :: Bool
looperSetPhase :: NominalDiffTime
looperSetPeriod :: NominalDiffTime
..}

mkLooperDef ::
  -- | Name
  Text ->
  LooperSettings ->
  -- | The function to loop
  m () ->
  LooperDef m
mkLooperDef :: forall (m :: * -> *). Text -> LooperSettings -> m () -> LooperDef m
mkLooperDef Text
n LooperSettings {Bool
NominalDiffTime
looperSetEnabled :: LooperSettings -> Bool
looperSetPhase :: LooperSettings -> NominalDiffTime
looperSetPeriod :: LooperSettings -> NominalDiffTime
looperSetEnabled :: Bool
looperSetPhase :: NominalDiffTime
looperSetPeriod :: NominalDiffTime
..} m ()
func =
  LooperDef
    { looperDefName :: Text
looperDefName = Text
n,
      looperDefEnabled :: Bool
looperDefEnabled = Bool
looperSetEnabled,
      looperDefPeriod :: NominalDiffTime
looperDefPeriod = NominalDiffTime
looperSetPeriod,
      looperDefPhase :: NominalDiffTime
looperDefPhase = NominalDiffTime
looperSetPhase,
      looperDefFunc :: m ()
looperDefFunc = m ()
func
    }

-- | Simply run loopers
--
-- > runLoopers = runLoopersIgnoreOverrun looperDefFunc
--
-- see 'runLoopersIgnoreOverrun'
--
-- Note that this function will loop forever, you need to wrap it using 'async' yourself.
runLoopers :: (MonadUnliftIO m) => [LooperDef m] -> m ()
runLoopers :: forall (m :: * -> *). MonadUnliftIO m => [LooperDef m] -> m ()
runLoopers = (LooperDef m -> m ()) -> [LooperDef m] -> m ()
forall (n :: * -> *) (m :: * -> *).
MonadUnliftIO n =>
(LooperDef m -> n ()) -> [LooperDef m] -> n ()
runLoopersIgnoreOverrun LooperDef m -> m ()
forall (m :: * -> *). LooperDef m -> m ()
looperDefFunc

-- | Run loopers with a custom runner, ignoring any overruns
--
-- > runLoopersIgnoreOverrun = runLoopersRaw (pure ())
--
-- see 'runLoopersRaw'
--
-- Note that this function will loop forever, you need to wrap it using 'async' yourself.
runLoopersIgnoreOverrun ::
  (MonadUnliftIO n) =>
  -- | Custom runner
  (LooperDef m -> n ()) ->
  -- | Loopers
  [LooperDef m] ->
  n ()
runLoopersIgnoreOverrun :: forall (n :: * -> *) (m :: * -> *).
MonadUnliftIO n =>
(LooperDef m -> n ()) -> [LooperDef m] -> n ()
runLoopersIgnoreOverrun = (LooperDef m -> n ())
-> (LooperDef m -> n ()) -> [LooperDef m] -> n ()
forall (n :: * -> *) (m :: * -> *).
MonadUnliftIO n =>
(LooperDef m -> n ())
-> (LooperDef m -> n ()) -> [LooperDef m] -> n ()
runLoopersRaw (n () -> LooperDef m -> n ()
forall a b. a -> b -> a
const (n () -> LooperDef m -> n ()) -> n () -> LooperDef m -> n ()
forall a b. (a -> b) -> a -> b
$ () -> n ()
forall a. a -> n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Run loopers, with a custom runner and overrun handler
--
-- * The overrun handler is run when the looper function takes longer than its period.
--   You can use this to log a warning, for example.
--
-- * The runner function is used to run the looper function
--   You can use 'looperDefFunc' @ :: LooperDef m -> m ()@ to run a 'LooperDef', and you
--   can wrap this function in some custom logic before you pass it into 'runLoopersRaw'
--   In this manner you can add logging or metrics, for example.
--
-- Note that this function will loop forever, you need to wrap it using 'async' yourself.
runLoopersRaw ::
  (MonadUnliftIO n) =>
  -- | Overrun handler
  (LooperDef m -> n ()) ->
  -- | Runner
  (LooperDef m -> n ()) ->
  -- | Loopers
  [LooperDef m] ->
  -- Returns unit because this finishes immediately if there are no loopers
  n ()
runLoopersRaw :: forall (n :: * -> *) (m :: * -> *).
MonadUnliftIO n =>
(LooperDef m -> n ())
-> (LooperDef m -> n ()) -> [LooperDef m] -> n ()
runLoopersRaw LooperDef m -> n ()
onOverrun LooperDef m -> n ()
runLooper [LooperDef m]
defs =
  (n Any -> n Any) -> [n Any] -> n ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ n Any -> n Any
forall a. a -> a
id ([n Any] -> n ()) -> [n Any] -> n ()
forall a b. (a -> b) -> a -> b
$ (LooperDef m -> Maybe (n Any)) -> [LooperDef m] -> [n Any]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((LooperDef m -> n ())
-> (LooperDef m -> n ()) -> LooperDef m -> Maybe (n Any)
forall (n :: * -> *) (m :: * -> *) void.
MonadUnliftIO n =>
(LooperDef m -> n ())
-> (LooperDef m -> n ()) -> LooperDef m -> Maybe (n void)
runLooperDef LooperDef m -> n ()
onOverrun LooperDef m -> n ()
runLooper) [LooperDef m]
defs

runLooperDef ::
  (MonadUnliftIO n) =>
  -- | Overrun handler
  (LooperDef m -> n ()) ->
  -- | Runner
  (LooperDef m -> n ()) ->
  -- | Loopers
  LooperDef m ->
  Maybe (n void)
runLooperDef :: forall (n :: * -> *) (m :: * -> *) void.
MonadUnliftIO n =>
(LooperDef m -> n ())
-> (LooperDef m -> n ()) -> LooperDef m -> Maybe (n void)
runLooperDef LooperDef m -> n ()
onOverrun LooperDef m -> n ()
runLooper ld :: LooperDef m
ld@LooperDef {m ()
Bool
Text
NominalDiffTime
looperDefName :: forall (m :: * -> *). LooperDef m -> Text
looperDefEnabled :: forall (m :: * -> *). LooperDef m -> Bool
looperDefPeriod :: forall (m :: * -> *). LooperDef m -> NominalDiffTime
looperDefPhase :: forall (m :: * -> *). LooperDef m -> NominalDiffTime
looperDefFunc :: forall (m :: * -> *). LooperDef m -> m ()
looperDefName :: Text
looperDefEnabled :: Bool
looperDefPeriod :: NominalDiffTime
looperDefPhase :: NominalDiffTime
looperDefFunc :: m ()
..} =
  if Bool
looperDefEnabled
    then n void -> Maybe (n void)
forall a. a -> Maybe a
Just (n void -> Maybe (n void)) -> n void -> Maybe (n void)
forall a b. (a -> b) -> a -> b
$ do
      NominalDiffTime -> n ()
forall (m :: * -> *). MonadIO m => NominalDiffTime -> m ()
waitNominalDiffTime NominalDiffTime
looperDefPhase
      let loop :: n b
loop = do
            UTCTime
start <- IO UTCTime -> n UTCTime
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            LooperDef m -> n ()
runLooper LooperDef m
ld
            UTCTime
end <- IO UTCTime -> n UTCTime
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let elapsed :: NominalDiffTime
elapsed = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start
            let nextWait :: NominalDiffTime
nextWait = NominalDiffTime
looperDefPeriod NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
elapsed
            if NominalDiffTime
nextWait NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
0
              then LooperDef m -> n ()
onOverrun LooperDef m
ld
              else NominalDiffTime -> n ()
forall (m :: * -> *). MonadIO m => NominalDiffTime -> m ()
waitNominalDiffTime NominalDiffTime
nextWait
            n b
loop
      n void
loop
    else Maybe (n void)
forall a. Maybe a
Nothing

-- | Wait for a given 'NominalDiffTime'
--
-- This takes care of the conversion to microseconds to pass to 'threadDelay' for you.
--
-- > waitNominalDiffTime ndt = liftIO $ threadDelay $ round (toRational ndt * (1000 * 1000))
waitNominalDiffTime :: (MonadIO m) => NominalDiffTime -> m ()
waitNominalDiffTime :: forall (m :: * -> *). MonadIO m => NominalDiffTime -> m ()
waitNominalDiffTime NominalDiffTime
ndt = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational NominalDiffTime
ndt Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1_000_000)