{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}

{- |
Module                  : Colog.Core.Class
Copyright               : (c) 2018-2020 Kowainik, 2021-2023 Co-Log
SPDX-License-Identifier : MPL-2.0
Maintainer              : Co-Log <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

Provides type class for values that has access to 'LogAction'.
-}

module Colog.Core.Class
       ( HasLog (..)

         -- * Lens
         -- $lens
       , Lens'
       ) where

import Colog.Core.Action  (LogAction)
import Data.Functor.Const (Const (..))


-- to inline lens better
{- HLINT ignore "Redundant lambda" -}

{- | This types class contains simple pair of getter-setter and related
functions.
It also provides the useful lens 'logActionL' with the default implementation using type
class methods. The default one could be easily overritten under your instances.

Every instance of the this typeclass should satisfy the following laws:

1. __Set-Get:__ @'getLogAction' ('setLogAction' l env) ≡ l@
2. __Get-Set:__ @'setLogAction' ('getLogAction' env) env ≡ env@
3. __Set-Set:__ @'setLogAction' l2 ('setLogAction' l1 env) ≡ 'setLogAction' l2 env@
4. __Set-Over:__ @'overLogAction' f env ≡ 'setLogAction' (f $ 'getLogAction' env) env@
-}
class HasLog env msg m where
    {-# MINIMAL logActionL | (getLogAction , (setLogAction | overLogAction)) #-}

    -- | Extracts 'LogAction' from the environment.
    getLogAction :: env -> LogAction m msg
    getLogAction = forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env msg (m :: * -> *).
HasLog env msg m =>
Lens' env (LogAction m msg)
logActionL forall {k} a (b :: k). a -> Const a b
Const
    {-# INLINE getLogAction #-}

    -- | Sets 'LogAction' to the given one inside the environment.
    setLogAction :: LogAction m msg -> env -> env
    setLogAction = forall env msg (m :: * -> *).
HasLog env msg m =>
(LogAction m msg -> LogAction m msg) -> env -> env
overLogAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
    {-# INLINE setLogAction #-}

    -- | Applies function to the 'LogAction' inside the environment.
    overLogAction :: (LogAction m msg -> LogAction m msg) -> env -> env
    overLogAction LogAction m msg -> LogAction m msg
f env
env = forall env msg (m :: * -> *).
HasLog env msg m =>
LogAction m msg -> env -> env
setLogAction (LogAction m msg -> LogAction m msg
f forall a b. (a -> b) -> a -> b
$ forall env msg (m :: * -> *).
HasLog env msg m =>
env -> LogAction m msg
getLogAction env
env) env
env
    {-# INLINE overLogAction #-}

    -- | Lens for 'LogAction' inside the environment.
    logActionL :: Lens' env (LogAction m msg)
    logActionL = forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens forall env msg (m :: * -> *).
HasLog env msg m =>
env -> LogAction m msg
getLogAction (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall env msg (m :: * -> *).
HasLog env msg m =>
LogAction m msg -> env -> env
setLogAction)
    {-# INLINE logActionL #-}

instance HasLog (LogAction m msg) msg m where
    getLogAction :: LogAction m msg -> LogAction m msg
    getLogAction :: LogAction m msg -> LogAction m msg
getLogAction = forall a. a -> a
id
    {-# INLINE getLogAction #-}

    setLogAction :: LogAction m msg -> LogAction m msg -> LogAction m msg
    setLogAction :: LogAction m msg -> LogAction m msg -> LogAction m msg
setLogAction = forall a b. a -> b -> a
const
    {-# INLINE setLogAction #-}

    overLogAction
        :: (LogAction m msg -> LogAction m msg)
        -> LogAction m msg
        -> LogAction m msg
    overLogAction :: (LogAction m msg -> LogAction m msg)
-> LogAction m msg -> LogAction m msg
overLogAction = forall a. a -> a
id
    {-# INLINE overLogAction #-}

    logActionL :: Lens' (LogAction m msg) (LogAction m msg)
    logActionL :: Lens' (LogAction m msg) (LogAction m msg)
logActionL = \LogAction m msg -> f (LogAction m msg)
f LogAction m msg
s -> LogAction m msg
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LogAction m msg -> f (LogAction m msg)
f LogAction m msg
s
    {-# INLINE logActionL #-}

----------------------------------------------------------------------------
-- Lens
----------------------------------------------------------------------------

{- $lens
To keep @co-log-core@ a lightweight library it was decided to introduce local
'Lens'' type alias as it doesn't harm.
-}

{- | The monomorphic lenses which don't change the type of the container (or of
the value inside).
-}
type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s

-- | Creates 'Lens'' from the getter and setter.
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens :: forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens s -> a
getter s -> a -> s
setter = \a -> f a
f s
s -> s -> a -> s
setter s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f (s -> a
getter s
s)
{-# INLINE lens #-}