ThrottleDebounce.purs

module ThrottleDebounce
  ( ThrottlingContext
  , newThrottlingContext
  , debounce
  , throttle
  ) where


import Control.Applicative (pure)
import Control.Bind (bind, discard, (>>=))
import Data.DateTime (DateTime)
import Data.DateTime as Datetime
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord ((<))
import Data.Semigroup ((<>))
import Data.Time.Duration (class Duration, Milliseconds, fromDuration, negateDuration)
import Data.Unit (Unit, unit)
import Effect.Aff (Aff)
import Effect.Aff as A
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Now (nowDateTime)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Partial.Unsafe (unsafePartial)
import Type.Data.Boolean (kind Boolean)


newtype ThrottlingContext a = ThrottlingContext
  { executor :: Ref (Maybe {action :: Aff a, time :: DateTime})
  , semaphore :: AV.AVar Unit }


newThrottlingContext :: forall a. Aff (ThrottlingContext a)
newThrottlingContext = do
  executor <- liftEffect $ Ref.new Nothing
  semaphore <- AV.empty
  pure $ ThrottlingContext { executor, semaphore }


throttle :: forall a d. Duration d => ThrottlingContext a -> d -> Aff a -> Aff (Maybe a)
throttle (ThrottlingContext {executor, semaphore}) delay action = do
  _ <- A.forkAff $ do
      _ <- liftEffect $ do
        time <- nowDateTime
        Ref.write (Just {action, time}) executor
      pure unit
  AV.tryPut unit semaphore >>= case _ of
    true -> do
      A.delay (fromDuration delay)
      exec <- unsafeRead executor
      liftEffect $ Ref.write Nothing executor
      _ <- AV.take semaphore
      Just <$> exec.action

    false -> pure Nothing


debounce :: forall a d. Duration d => ThrottlingContext a -> d -> Aff a -> Aff (Maybe a)
debounce (ThrottlingContext {executor, semaphore}) delay action =
  let delayMs = (fromDuration delay) :: Milliseconds
  in do
  _ <- A.forkAff $ do
      _ <- liftEffect $ do
        time <- nowDateTime
        Ref.write (Just {action, time}) executor
      pure unit
  AV.tryPut unit semaphore >>= case _ of
    true ->
      let loop x = do
            A.delay x
            now <- liftEffect nowDateTime
            exec <- unsafeRead executor
            let td = Datetime.diff now exec.time
            if td < delayMs
              then loop (delayMs <> negateDuration td)
              else do
                pure exec.action

      in do
        exec <- loop delayMs
        liftEffect $ Ref.write Nothing executor
        _ <- AV.take semaphore
        Just <$> exec

    false -> pure Nothing


unsafeRead :: forall a . Ref (Maybe a) -> Aff a
unsafeRead r = liftEffect $ do
  mr <- Ref.read r
  pure $ unsafePartial $ fromJust mr