{-# 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 :: (b -> p) -> Sem r a -> Sem r a
logMethodologyStart b -> p
f = (forall x (m :: * -> *). Methodology b c m x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (m :: * -> *). e m x -> Sem r x) -> Sem r a -> Sem r a
intercept \case
  Process b -> p -> Sem r ()
forall msg (r :: [Effect]). Member (Log msg) r => msg -> Sem r ()
C.log (b -> p
f b
b) Sem r () -> Sem r c -> Sem r c
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Sem r c
forall b c (r :: [Effect]).
MemberWithError (Methodology b c) r =>
b -> Sem r c
process @b @c b
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 :: (c -> q) -> Sem r a -> Sem r a
logMethodologyEnd c -> q
f = (forall x (m :: * -> *). Methodology b c m x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (m :: * -> *). e m x -> Sem r x) -> Sem r a -> Sem r a
intercept \case
  Process b -> do
    c
c <- b -> Sem r c
forall b c (r :: [Effect]).
MemberWithError (Methodology b c) r =>
b -> Sem r c
process @b @c b
b
    q -> Sem r ()
forall msg (r :: [Effect]). Member (Log msg) r => msg -> Sem r ()
C.log (q -> Sem r ()) -> q -> Sem r ()
forall a b. (a -> b) -> a -> b
$ c -> q
f c
c
    c -> Sem r c
forall (m :: * -> *) a. Monad m => a -> m a
return c
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 :: (b -> p) -> (c -> q) -> Sem r a -> Sem r a
logMethodologyAround b -> p
f c -> q
g = (forall x (m :: * -> *). Methodology b c m x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (m :: * -> *). e m x -> Sem r x) -> Sem r a -> Sem r a
intercept \case
  Process b -> do
    p -> Sem r ()
forall msg (r :: [Effect]). Member (Log msg) r => msg -> Sem r ()
C.log (p -> Sem r ()) -> p -> Sem r ()
forall a b. (a -> b) -> a -> b
$ b -> p
f b
b
    c
c <- b -> Sem r c
forall b c (r :: [Effect]).
MemberWithError (Methodology b c) r =>
b -> Sem r c
process @b @c b
b
    q -> Sem r ()
forall msg (r :: [Effect]). Member (Log msg) r => msg -> Sem r ()
C.log (q -> Sem r ()) -> q -> Sem r ()
forall a b. (a -> b) -> a -> b
$ c -> q
g c
c
    c -> Sem r c
forall (m :: * -> *) a. Monad m => a -> m a
return c
c
{-# INLINE logMethodologyAround #-}