{-# 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.Colog
(
logMethodologyStart,
logMethodologyEnd,
logMethodologyAround,
)
where
import Colog.Polysemy as C
import Polysemy
import Polysemy.Methodology
logMethodologyStart ::
forall b c p r a.
Members
'[ Methodology b c,
Log p
]
r =>
(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 #-}
logMethodologyEnd ::
forall b c q r a.
Members
'[ Methodology b c,
Log q
]
r =>
(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 #-}
logMethodologyAround ::
forall b c p q r a.
Members
'[ Methodology b c,
Log p,
Log q
]
r =>
(b -> p) ->
(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 #-}