{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Yesod.Katip.Class
Description : Class and instances for Katip logging in Yesod handlers
Copyright   : (c) Isaac van Bakel, 2020
License     : BSD3
Maintainer  : ivb@vanbakel.io
Stability   : experimental
Portability : POSIX

This module defines the classes associated with the site transformers @KatipSite@
and @KatipContextSite@.

It also includes instances for 'Katip' and 'KatipContext' (the Katip classes)
which let you invoke the Katip logging APIs in your handlers, provided the site
itself satisfies the 'SiteKatip' or 'SiteKatipContext' class respectively.

By default, you won't need to use any of these APIs directly. While the classes
defined here have APIs identical to their Katip counterparts, it's always better
to rely on the Katip APIs.
-}

module Yesod.Katip.Class
  ( SiteKatip (..)
  , SiteKatipContext (..)
  ) where

import qualified Katip as K
import Yesod.Site.Class
import Yesod.Trans.Class

-- | A class for sites which provide a 'Katip'-equivalent API
class SiteKatip site where
  getLogEnv :: (MonadSite m) => m site K.LogEnv
  localLogEnv :: (MonadSite m) => (K.LogEnv -> K.LogEnv) -> m site a -> m site a

-- | A class for sites which provide a 'KatipContext'-equivalent API
class SiteKatip site => SiteKatipContext site where
  getKatipContext :: (MonadSite m) => m site K.LogContexts
  localKatipContext :: (MonadSite m) => (K.LogContexts -> K.LogContexts) -> m site a -> m site a

  getKatipNamespace :: (MonadSite m) => m site K.Namespace
  localKatipNamespace :: (MonadSite m) => (K.Namespace -> K.Namespace) -> m site a -> m site a

instance {-# OVERLAPPABLE #-}
  (SiteTrans t, SiteKatip site) => SiteKatip (t site) where
  getLogEnv :: m (t site) LogEnv
getLogEnv = m site LogEnv -> m (t site) LogEnv
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift m site LogEnv
forall site (m :: * -> * -> *).
(SiteKatip site, MonadSite m) =>
m site LogEnv
getLogEnv
  localLogEnv :: (LogEnv -> LogEnv) -> m (t site) a -> m (t site) a
localLogEnv = (m site a -> m site a) -> m (t site) a -> m (t site) a
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT ((m site a -> m site a) -> m (t site) a -> m (t site) a)
-> ((LogEnv -> LogEnv) -> m site a -> m site a)
-> (LogEnv -> LogEnv)
-> m (t site) a
-> m (t site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatip site, MonadSite m) =>
(LogEnv -> LogEnv) -> m site a -> m site a
localLogEnv

instance {-# OVERLAPPABLE #-}
  (SiteTrans t, SiteKatipContext site) => SiteKatipContext (t site) where
  getKatipContext :: m (t site) LogContexts
getKatipContext = m site LogContexts -> m (t site) LogContexts
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift m site LogContexts
forall site (m :: * -> * -> *).
(SiteKatipContext site, MonadSite m) =>
m site LogContexts
getKatipContext
  localKatipContext :: (LogContexts -> LogContexts) -> m (t site) a -> m (t site) a
localKatipContext = (m site a -> m site a) -> m (t site) a -> m (t site) a
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT ((m site a -> m site a) -> m (t site) a -> m (t site) a)
-> ((LogContexts -> LogContexts) -> m site a -> m site a)
-> (LogContexts -> LogContexts)
-> m (t site) a
-> m (t site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogContexts -> LogContexts) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatipContext site, MonadSite m) =>
(LogContexts -> LogContexts) -> m site a -> m site a
localKatipContext
  
  getKatipNamespace :: m (t site) Namespace
getKatipNamespace = m site Namespace -> m (t site) Namespace
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift m site Namespace
forall site (m :: * -> * -> *).
(SiteKatipContext site, MonadSite m) =>
m site Namespace
getKatipNamespace
  localKatipNamespace :: (Namespace -> Namespace) -> m (t site) a -> m (t site) a
localKatipNamespace = (m site a -> m site a) -> m (t site) a -> m (t site) a
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT ((m site a -> m site a) -> m (t site) a -> m (t site) a)
-> ((Namespace -> Namespace) -> m site a -> m site a)
-> (Namespace -> Namespace)
-> m (t site) a
-> m (t site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Namespace -> Namespace) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatipContext site, MonadSite m) =>
(Namespace -> Namespace) -> m site a -> m site a
localKatipNamespace

instance (MonadSite m, SiteKatip site) => K.Katip (m site) where
  getLogEnv :: m site LogEnv
getLogEnv = m site LogEnv
forall site (m :: * -> * -> *).
(SiteKatip site, MonadSite m) =>
m site LogEnv
getLogEnv
  localLogEnv :: (LogEnv -> LogEnv) -> m site a -> m site a
localLogEnv = (LogEnv -> LogEnv) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatip site, MonadSite m) =>
(LogEnv -> LogEnv) -> m site a -> m site a
localLogEnv

instance (MonadSite m, SiteKatipContext site) => K.KatipContext (m site) where
  getKatipContext :: m site LogContexts
getKatipContext = m site LogContexts
forall site (m :: * -> * -> *).
(SiteKatipContext site, MonadSite m) =>
m site LogContexts
getKatipContext
  localKatipContext :: (LogContexts -> LogContexts) -> m site a -> m site a
localKatipContext = (LogContexts -> LogContexts) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatipContext site, MonadSite m) =>
(LogContexts -> LogContexts) -> m site a -> m site a
localKatipContext

  getKatipNamespace :: m site Namespace
getKatipNamespace = m site Namespace
forall site (m :: * -> * -> *).
(SiteKatipContext site, MonadSite m) =>
m site Namespace
getKatipNamespace
  localKatipNamespace :: (Namespace -> Namespace) -> m site a -> m site a
localKatipNamespace = (Namespace -> Namespace) -> m site a -> m site a
forall site (m :: * -> * -> *) a.
(SiteKatipContext site, MonadSite m) =>
(Namespace -> Namespace) -> m site a -> m site a
localKatipNamespace