Unclog.hs

{-# LANGUAGE UndecidableInstances #-}

-- | running the @fused-effects@ frontend
module Control.Carrier.Unclog (UnclogC (..), runUnclogging, runUncloggingToList) where

import Chronos (now)
import Control.Algebra (Algebra (..), (:+:) (..))
import Control.Applicative (Alternative)
import Control.Carrier.Reader (ReaderC (..))
import Control.Effect.Unclog (Log (..))
import Control.Monad (MonadPlus)
import Control.Monad.Fix (MonadFix)
import Data.Kind (Type)
import Unclog.Common (LogEntry, PLogChan)
import Unclog.Frontend qualified as Frontend
import Unclog.Subscriber (Subscriber, refSubscriber, withLoggingWithSubscribers)
import UnliftIO (MonadIO (..), MonadUnliftIO, atomically, newIORef, readIORef)

-- | the 'IO' carrier for unclogging
type UnclogC :: (Type -> Type) -> Type -> Type
newtype UnclogC m r = MkUnclogC {runUnclogC :: PLogChan -> m r}
  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, Alternative, MonadPlus, MonadFail, MonadFix) via ReaderC PLogChan m

instance (Algebra sig m, MonadIO m) => Algebra (Log :+: sig) (UnclogC m) where
  alg hdl sig ctx = case sig of
    L (PublishLogEntry entry) -> MkUnclogC \chan -> do
      ts <- liftIO now
      ctx <$ atomically (Frontend.publishLogEntry chan $ entry ts)
    R other -> MkUnclogC \chan -> alg (flip runUnclogC chan . hdl) other ctx

-- | run the logging effect into multiple subscribers.
-- this is what you would use in actual code
runUnclogging :: MonadUnliftIO m => [Subscriber m] -> UnclogC m a -> m a
runUnclogging subs act = withLoggingWithSubscribers subs (runUnclogC act)

-- | run the logging effect and simply collect the log entries.
-- this is useful to check if e.g. a specific log entry was emitted in tests
runUncloggingToList :: MonadUnliftIO m => UnclogC m a -> m ([LogEntry], a)
runUncloggingToList act = do
  ref <- newIORef []
  res <- withLoggingWithSubscribers [refSubscriber ref] (runUnclogC act)
  logs <- readIORef ref
  pure (reverse logs, res)