content: --  This Source Code Form is subject to the terms of the Mozilla Public
  --  License, v. 2.0. If a copy of the MPL was not distributed with this
  --  file, You can obtain one at http://mozilla.org/MPL/2.0/.
  
  {-# LANGUAGE TypeOperators #-}
  
  {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
  {-# OPTIONS_HADDOCK prune #-}
  
  -- | This module provides a way to generically define and configure multiple
  -- tracers for multiple logging components.
  --
  -- This is useful in order to associate separate configuration (e.g. minimum
  -- severity) to tracers corresponding to different parts of an application. For
  -- example, in a webserver, one may imagine wanting to lower the verbosity of a
  -- tracer used for all HTTP requests, but keep the database tracer at a debug
  -- level.
  --
  -- While this is possible to do without generics, it usually requires a bit of
  -- boilerplate and repetitions. This module makes it easy to define one-single
  -- data object as a record, for representing both severities configurations and
  -- concrete instantiated tracers. Type signatures are a bit frightening, but the
  -- usage is pretty simple (see 'Control.Tracer' for examples)
  --
  module Data.Generics.Tracers
      ( -- * Definition
        IsRecordOfTracers
      , TracerDefinition (..)
      , type TracerHKD
  
      -- * Construction
      , configureTracers
      , defaultTracers
  
      -- Internal
      , SomeMsg (..)
      ) where
  
  import Prelude
  
  import GHC.Generics
  
  import Control.Tracer
      ( Tracer (..), nullTracer )
  import Data.Aeson
      ( ToJSON (..) )
  import Data.Functor.Const
      ( Const (..) )
  import Data.Functor.Contravariant
      ( contramap )
  import Data.Kind
      ( Type )
  import Data.Severity
      ( HasSeverityAnnotation (..), Severity )
  
  -- * Definition
  
  -- | A constraint-alias defining generic record of tracers.
  type IsRecordOfTracers tracers m =
      ( GConfigureTracers m (Rep (tracers m MinSeverities)) (Rep (tracers m Concrete))
      , Generic (tracers m MinSeverities)
      , Generic (tracers m Concrete)
      )
  
  -- | A data kind to control what's defined in a generic record of tracer.
  --
  -- Use 'configureTracers' to turn a record of configuration into a record of
  -- concrete tracers.
  data TracerDefinition = Concrete | MinSeverities
  
  -- | A high-kinded type family to make definitions of tracers more readable. For
  -- example, one can define a multi-component set of tracers as such:
  --
  --     data Tracers m (kind :: TracerDefinition) = Tracers
  --         { tracerHttp  :: TracerHKD kind (Tracer m HttpLog)
  --         , tracerStart :: TracerHKD kind (Tracer m StartLog)
  --         }
  type family TracerHKD (definition :: TracerDefinition) (tracer :: Type) :: Type where
      TracerHKD MinSeverities tracer = Const (Maybe Severity) tracer
      TracerHKD Concrete tracer = tracer
  
  -- * Construction
  
  -- | Convert a 'MinSeverities' of tracers into a 'Concrete' record of tracers,
  -- using a base opaque 'Tracer'.
  configureTracers
      :: ( IsRecordOfTracers tracers m )
      => tracers m MinSeverities
      -> Tracer m SomeMsg
      -> tracers m Concrete
  configureTracers f tr =
      to . gConfigureTracers mempty tr . from $ f
  
  class GConfigureTracers m (f :: Type -> Type) (g :: Type -> Type) where
      gConfigureTracers
          :: String
          -> Tracer m SomeMsg
          -> f (Const (Maybe Severity) tr)
          -> g tr
  
  instance GConfigureTracers m f g => GConfigureTracers m (D1 c f) (D1 c g) where
      gConfigureTracers field tr = M1 . gConfigureTracers field tr . unM1
  
  instance GConfigureTracers m f g => GConfigureTracers m (C1 c f) (C1 c g) where
      gConfigureTracers field tr = M1 . gConfigureTracers field tr . unM1
  
  instance (Selector s, GConfigureTracers m f g) => GConfigureTracers m (S1 s f) (S1 s g) where
      gConfigureTracers _ tr = M1 . gConfigureTracers field tr . unM1
        where
          field = selName (undefined :: S1 s f a)
  
  instance (GConfigureTracers m f0 g0, GConfigureTracers m f1 g1)
      => GConfigureTracers m (f0 :*: f1) (g0 :*: g1)
    where
      gConfigureTracers field tr (f0 :*: f1) =
          gConfigureTracers field tr f0
          :*:
          gConfigureTracers field tr f1
  
  instance (ToJSON msg, HasSeverityAnnotation msg, Applicative m)
      => GConfigureTracers m (K1 i (Const (Maybe Severity) (Tracer m msg))) (K1 i (Tracer m msg))
    where
      gConfigureTracers field tr = \case
          K1 (Const (Just minSeverity)) ->
              K1 (contramap (SomeMsg minSeverity field) tr)
          K1 (Const Nothing) ->
              K1 nullTracer
  
  -- | Assign a default value to a record of tracers.
  --
  -- This is useful when used in conjunction with 'Const' and a record of tracer
  -- severities:
  --
  --     defaultTracers Info == Tracers
  --         { tracerHttp = Const (Just Info)
  --         , tracerDb = Const (Just Info)
  --         }
  --
  defaultTracers
      :: forall tracers (m :: Type -> Type).
          ( Generic (tracers m MinSeverities)
          , GDefaultRecord (Rep (tracers m MinSeverities))
          , GDefaultRecordType (Rep (tracers m MinSeverities)) ~ Maybe Severity
          )
      => Maybe Severity
      -> tracers m MinSeverities
  defaultTracers =
      to . gDefaultRecord
  
  -- | This generic class allows for defining a default value to a record of
  -- functors wrapping some type 'a'.
  class GDefaultRecord (f :: Type -> Type) where
      type GDefaultRecordType f :: Type
      gDefaultRecord :: GDefaultRecordType f -> f (Const (GDefaultRecordType f) b)
  
  instance GDefaultRecord f => GDefaultRecord (D1 c f) where
      type GDefaultRecordType (D1 c f) = GDefaultRecordType f
      gDefaultRecord a = M1 (gDefaultRecord a)
  
  instance GDefaultRecord f => GDefaultRecord (C1 c f) where
      type GDefaultRecordType (C1 c f) = GDefaultRecordType f
      gDefaultRecord a = M1 (gDefaultRecord a)
  
  instance GDefaultRecord f => GDefaultRecord (S1 c f) where
      type GDefaultRecordType (S1 c f) = GDefaultRecordType f
      gDefaultRecord a = M1 (gDefaultRecord a)
  
  instance (GDefaultRecord f, GDefaultRecord g, GDefaultRecordType f ~ GDefaultRecordType g) => GDefaultRecord (f :*: g) where
      type GDefaultRecordType (f :*: g) = GDefaultRecordType f
      gDefaultRecord a = gDefaultRecord a :*: gDefaultRecord a
  
  instance GDefaultRecord (K1 i (Const a b)) where
      type GDefaultRecordType (K1 i (Const a b)) = a
      gDefaultRecord a = K1 (Const a)
  
  -- Internal
  
  -- A GADT capturing constraints as existential.
  data SomeMsg where
      SomeMsg
          :: forall msg. (ToJSON msg, HasSeverityAnnotation msg)
          => Severity
          -> String
          -> msg
          -> SomeMsg
  