polysemy-methodology-co-log-0.1.0.0: src/Polysemy/Methodology/Colog.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

-- |
--   Module     : Polysemy.Methodology
--   License    : MIT
--   Stability  : experimental
--
-- Domain modelling algebra for polysemy.
module Polysemy.Methodology.Colog
  ( -- * Logging
    logMethodologyStart,
    logMethodologyEnd,
    logMethodologyAround,
  )
where

import Colog.Polysemy as C
import Polysemy
import Polysemy.Methodology

-- | `Log` a type based on the input to a `Methodology`.
--
-- @since 0.1.0.0
logMethodologyStart ::
  forall b c p r a.
  Members
    '[ Methodology b c,
       Log p
     ]
    r =>
  -- | A function from the input type b to an event type p.
  (b -> p) ->
  Sem r a ->
  Sem r a
logMethodologyStart f = intercept \case
  Process b -> C.log (f b) >> process @b @c b
{-# INLINE logMethodologyStart #-}

-- | `Log` a type based on the output to a `Methodology`.
--
-- @since 0.1.0.0
logMethodologyEnd ::
  forall b c q r a.
  Members
    '[ Methodology b c,
       Log q
     ]
    r =>
  -- | A function from the input type c to an event type q.
  (c -> q) ->
  Sem r a ->
  Sem r a
logMethodologyEnd f = intercept \case
  Process b -> do
    c <- process @b @c b
    C.log $ f c
    return c
{-# INLINE logMethodologyEnd #-}

-- | `Log` both the start and the end of a `Methodology`.
--
-- @since 0.1.0.0
logMethodologyAround ::
  forall b c p q r a.
  Members
    '[ Methodology b c,
       Log p,
       Log q
     ]
    r =>
  -- | A function from the input type b to an event type p.
  (b -> p) ->
  -- | A function from the output type b to an event type q,
  (c -> q) ->
  Sem r a ->
  Sem r a
logMethodologyAround f g = intercept \case
  Process b -> do
    C.log $ f b
    c <- process @b @c b
    C.log $ g c
    return c
{-# INLINE logMethodologyAround #-}