Util.hs

{-|
Module      : KMonad.Util
Description : Various bits and bobs that I don't know where to put
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

Contains code for making it slighly easier to work with time, errors, and
Acquire datatypes.

-}
module KMonad.Util
  ( -- * Time units and utils
    -- $time
    Milliseconds
  , unMS
  , tDiff

    -- * Random utility helpers that have no better home
  , onErr
  , using
  , duplicatesWith
  , logRethrow

    -- * Some helpers to launch background process
  , withLaunch
  , withLaunch_
  , launch
  , launch_
  )

where

import KMonad.Prelude

import Data.Time.Clock
import Data.Time.Clock.System

import qualified RIO.NonEmpty as NE

--------------------------------------------------------------------------------
-- $time
--

-- | Newtype wrapper around 'Int' to add type safety to our time values
newtype Milliseconds = Milliseconds { unMS :: Int }
  deriving (Eq, Ord, Num, Real, Enum, Integral, Show, Read, Generic, Display, Typeable, Data)

-- | Calculate how much time has elapsed between 2 time points
tDiff :: ()
  => SystemTime   -- ^ The earlier timepoint
  -> SystemTime   -- ^ The later timepoint
  -> Milliseconds -- ^ The time in milliseconds between the two
tDiff a b = let
  a' = systemToUTCTime a
  b' = systemToUTCTime b
  d  = diffUTCTime b' a'
  in round $ d * 1000
-- tDiff (MkSystemTime s_a ns_a) (MkSystemTime s_b ns_b) = let
  -- s  = fromIntegral $ (s_b  - s_a) * 1000
  -- ns = fromIntegral $ (ns_b - ns_a) `div` 1000000
  -- in s + ns

--------------------------------------------------------------------------------
-- $util

-- | A helper function that helps to throw errors when a return code is -1.
-- Easiest when used as infix like this:
--
-- > someFFIcall `onErr` MyCallFailedError someData
--
onErr :: (MonadUnliftIO m, Exception e) => m Int -> e -> m ()
onErr a err = a >>= \ret -> when (ret == -1) $ throwIO err

-- | Embed the action of using an 'Acquire' in a continuation monad
using :: Acquire a -> ContT r (RIO e) a
using dat = ContT (\next -> with dat $ \a -> next a)

-- | Get a list duplicates with the selected field identical
duplicatesWith :: Ord b => (a -> b) -> [a] -> [NonEmpty a]
duplicatesWith f = filter (not . null . NE.tail) . NE.groupAllWith f


-- | Log an error message and then rethrow the error
--
-- Particularly useful as a suffix using `catch`. i.e.
--
-- > doSomething `catch` logRethrow "I caught something"
logRethrow :: HasLogFunc e
  => Text
  -> SomeException -- ^ The error to throw
  -> RIO e a
logRethrow t e = do
  logError $ display t <> ": " <> display e
  throwIO e

-- | Launch a process that repeats an action indefinitely. If an error ever
-- occurs, print it and rethrow it. Ensure the process is cleaned up upon error
-- and/or shutdown.
withLaunch :: HasLogFunc e
  => Text                   -- ^ The name of this process (for logging)
  -> RIO e a                -- ^ The action to repeat forever
  -> (Async a -> RIO e b) -- ^ The foreground action to run
  -> RIO e b                -- ^ The resulting action
withLaunch n a f = do
  logInfo $ "Launching process: " <> display n
  withAsync
   (forever a
    `catch`   logRethrow ("Encountered error in <" <> textDisplay n <> ">")
    `finally` logInfo    ("Closing process: " <> display n))
   (\a' -> link a' >> f a')

-- | Like withLaunch, but without ever needing access to the async process
withLaunch_ :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> RIO e b -- ^ The foreground action to run
  -> RIO e b -- ^ The resulting action
withLaunch_ n a f = withLaunch n a (const f)

-- | Like 'withLaunch', but in the ContT monad
launch :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> ContT r (RIO e) (Async a)
launch n = ContT . withLaunch n

-- | Like 'withLaunch_', but in the ContT monad
launch_ :: HasLogFunc e
  => Text    -- ^ The name of this process (for logging)
  -> RIO e a -- ^ The action to repeat forever
  -> ContT r (RIO e) ()
launch_ n a = ContT $ \next -> withLaunch_ n a (next ())