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

{- |
Copyright:  (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

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 = Const (LogAction m msg) env -> LogAction m msg
forall a k (b :: k). Const a b -> a
getConst (Const (LogAction m msg) env -> LogAction m msg)
-> (env -> Const (LogAction m msg) env) -> env -> LogAction m msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogAction m msg -> Const (LogAction m msg) (LogAction m msg))
-> env -> Const (LogAction m msg) env
forall env msg (m :: * -> *).
HasLog env msg m =>
Lens' env (LogAction m msg)
logActionL LogAction m msg -> Const (LogAction m msg) (LogAction m msg)
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 = (LogAction m msg -> LogAction m msg) -> env -> env
forall env msg (m :: * -> *).
HasLog env msg m =>
(LogAction m msg -> LogAction m msg) -> env -> env
overLogAction ((LogAction m msg -> LogAction m msg) -> env -> env)
-> (LogAction m msg -> LogAction m msg -> LogAction m msg)
-> LogAction m msg
-> env
-> env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogAction m msg -> LogAction m msg -> LogAction m msg
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 f :: LogAction m msg -> LogAction m msg
f env :: env
env = LogAction m msg -> env -> env
forall env msg (m :: * -> *).
HasLog env msg m =>
LogAction m msg -> env -> env
setLogAction (LogAction m msg -> LogAction m msg
f (LogAction m msg -> LogAction m msg)
-> LogAction m msg -> LogAction m msg
forall a b. (a -> b) -> a -> b
$ env -> LogAction m msg
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 = (env -> LogAction m msg)
-> (env -> LogAction m msg -> env) -> Lens' env (LogAction m msg)
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens env -> LogAction m msg
forall env msg (m :: * -> *).
HasLog env msg m =>
env -> LogAction m msg
getLogAction ((LogAction m msg -> env -> env) -> env -> LogAction m msg -> env
forall a b c. (a -> b -> c) -> b -> a -> c
flip LogAction m msg -> env -> env
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 = LogAction m msg -> LogAction m msg
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 = LogAction m msg -> LogAction m msg -> LogAction m msg
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 = (LogAction m msg -> LogAction m msg)
-> LogAction m msg -> LogAction m msg
forall a. a -> a
id
    {-# INLINE overLogAction #-}

    logActionL :: Lens' (LogAction m msg) (LogAction m msg)
    logActionL :: (LogAction m msg -> f (LogAction m msg))
-> LogAction m msg -> f (LogAction m msg)
logActionL = \f :: LogAction m msg -> f (LogAction m msg)
f s :: LogAction m msg
s -> LogAction m msg
s LogAction m msg -> f (LogAction m msg) -> f (LogAction m msg)
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 :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens getter :: s -> a
getter setter :: s -> a -> s
setter = \f :: a -> f a
f s :: s
s -> s -> a -> s
setter s
s (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f (s -> a
getter s
s)
{-# INLINE lens #-}