{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides the core 'Env' type for Navi.
module Navi.Env.Core
  ( -- * HasX-style Typeclasses
    HasEvents (..),
    HasLogEnv (..),
    HasNoteQueue (..),
    sendNoteQueue,

    -- ** Deriving
    TopField (..),
    CoreEnvField (..),

    -- * Concrete Env
    Env (..),
  )
where

import Navi.Config.Phase (ConfigPhase (ConfigPhaseEnv))
import Navi.Config.Types (NoteSystem)
import Navi.Data.NaviLog (LogEnv)
import Navi.Data.NaviNote (NaviNote)
import Navi.Event.Types (AnyEvent)
import Navi.Prelude

-- | 'Env' holds all of our environment data that is used while running navi.
data Env = MkEnv
  { Env -> NonEmpty AnyEvent
events :: NonEmpty AnyEvent,
    Env -> Maybe LogEnv
logEnv :: Maybe LogEnv,
    Env -> TBQueue NaviNote
noteQueue :: TBQueue NaviNote,
    Env -> NoteSystem 'ConfigPhaseEnv
notifySystem :: NoteSystem ConfigPhaseEnv
  }

makeFieldLabelsNoPrefix ''Env

deriving via (TopField Env) instance HasEvents Env

deriving via (TopField Env) instance HasLogEnv Env

deriving via (TopField Env) instance HasNoteQueue Env

-- | Used for deriving instances from the top level field name e.g.
-- 'events :: NonEmpty AnyEvent'.
type TopField :: Type -> Type
newtype TopField a = MkTopField a

-- | Used for deriving instances for types with a field 'coreEnv :: Env'.
type CoreEnvField :: Type -> Type
newtype CoreEnvField a = MkCoreEnvField a

-- | Retrieves the events.
class HasEvents env where
  getEvents :: env -> NonEmpty AnyEvent

-- | Retrieves the log environment.
class HasLogEnv env where
  getLogEnv :: env -> Maybe LogEnv

-- | Retrieves the note queue.
class HasNoteQueue env where
  getNoteQueue :: env -> TBQueue NaviNote

-- NOTE: For some reason, we cannot really compose these optics together
-- e.g. view (#coreEnv % #events) fails to typecheck. Probably there's a
-- way to do this with castOptic, but reusing the instance itself is easy.

instance
  (Is k A_Getter, LabelOptic' "events" k a (NonEmpty AnyEvent)) =>
  HasEvents (TopField a)
  where
  getEvents :: TopField a -> NonEmpty AnyEvent
getEvents (MkTopField a
x) = Optic' k NoIx a (NonEmpty AnyEvent) -> a -> NonEmpty AnyEvent
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a (NonEmpty AnyEvent)
#events a
x

instance
  (Is k A_Getter, LabelOptic' "coreEnv" k a Env) =>
  HasEvents (CoreEnvField a)
  where
  getEvents :: CoreEnvField a -> NonEmpty AnyEvent
getEvents (MkCoreEnvField a
x) = Env -> NonEmpty AnyEvent
forall (env :: OpticKind).
HasEvents env =>
env -> NonEmpty AnyEvent
getEvents (Env -> NonEmpty AnyEvent) -> Env -> NonEmpty AnyEvent
forall a b. (a -> b) -> a -> b
$ Optic' k NoIx a Env -> a -> Env
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a Env
#coreEnv a
x

instance
  (Is k A_Getter, LabelOptic' "logEnv" k a (Maybe LogEnv)) =>
  HasLogEnv (TopField a)
  where
  getLogEnv :: TopField a -> Maybe LogEnv
getLogEnv (MkTopField a
x) = Optic' k NoIx a (Maybe LogEnv) -> a -> Maybe LogEnv
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a (Maybe LogEnv)
#logEnv a
x

instance
  (Is k A_Getter, LabelOptic' "coreEnv" k a Env) =>
  HasLogEnv (CoreEnvField a)
  where
  getLogEnv :: CoreEnvField a -> Maybe LogEnv
getLogEnv (MkCoreEnvField a
x) = Env -> Maybe LogEnv
forall (env :: OpticKind). HasLogEnv env => env -> Maybe LogEnv
getLogEnv (Env -> Maybe LogEnv) -> Env -> Maybe LogEnv
forall a b. (a -> b) -> a -> b
$ Optic' k NoIx a Env -> a -> Env
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a Env
#coreEnv a
x

instance
  (Is k A_Getter, LabelOptic' "noteQueue" k a (TBQueue NaviNote)) =>
  HasNoteQueue (TopField a)
  where
  getNoteQueue :: TopField a -> TBQueue NaviNote
getNoteQueue (MkTopField a
x) = Optic' k NoIx a (TBQueue NaviNote) -> a -> TBQueue NaviNote
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a (TBQueue NaviNote)
#noteQueue a
x

instance
  (Is k A_Getter, LabelOptic' "coreEnv" k a Env) =>
  HasNoteQueue (CoreEnvField a)
  where
  getNoteQueue :: CoreEnvField a -> TBQueue NaviNote
getNoteQueue (MkCoreEnvField a
x) = Env -> TBQueue NaviNote
forall (env :: OpticKind).
HasNoteQueue env =>
env -> TBQueue NaviNote
getNoteQueue (Env -> TBQueue NaviNote) -> Env -> TBQueue NaviNote
forall a b. (a -> b) -> a -> b
$ Optic' k NoIx a Env -> a -> Env
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k NoIx a Env
#coreEnv a
x

instance
  ( k ~ A_Lens,
    x ~ Namespace,
    y ~ Namespace
  ) =>
  LabelOptic "namespace" k Env Env x y
  where
  labelOptic :: Optic k NoIx Env Env x y
labelOptic =
    LensVL Env Env x y -> Lens Env Env x y
forall (s :: OpticKind) (t :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
LensVL s t a b -> Lens s t a b
lensVL (LensVL Env Env x y -> Lens Env Env x y)
-> LensVL Env Env x y -> Lens Env Env x y
forall a b. (a -> b) -> a -> b
$ \x -> f y
f (MkEnv NonEmpty AnyEvent
a1 Maybe LogEnv
a2 TBQueue NaviNote
a3 NoteSystem 'ConfigPhaseEnv
a4) ->
      (y -> Env) -> f y -> f Env
forall (a :: OpticKind) (b :: OpticKind). (a -> b) -> f a -> f b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
fmap
        (\y
b -> NonEmpty AnyEvent
-> Maybe LogEnv
-> TBQueue NaviNote
-> NoteSystem 'ConfigPhaseEnv
-> Env
MkEnv NonEmpty AnyEvent
a1 (Optic
  An_AffineTraversal NoIx (Maybe LogEnv) (Maybe LogEnv) Namespace y
-> y -> Maybe LogEnv -> Maybe LogEnv
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (t :: OpticKind) (a :: OpticKind) (b :: OpticKind).
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set' (Prism (Maybe LogEnv) (Maybe LogEnv) LogEnv LogEnv
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe LogEnv) (Maybe LogEnv) LogEnv LogEnv
-> Optic A_Lens NoIx LogEnv LogEnv Namespace y
-> Optic
     An_AffineTraversal NoIx (Maybe LogEnv) (Maybe LogEnv) Namespace y
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx LogEnv LogEnv Namespace y
#logNamespace) y
b Maybe LogEnv
a2) TBQueue NaviNote
a3 NoteSystem 'ConfigPhaseEnv
a4)
        (x -> f y
f (x -> f y) -> x -> f y
forall a b. (a -> b) -> a -> b
$ x -> Maybe x -> x
forall (a :: OpticKind). a -> Maybe a -> a
fromMaybe x
"" (Maybe LogEnv
a2 Maybe LogEnv
-> Optic' An_AffineTraversal NoIx (Maybe LogEnv) x -> Maybe x
forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Prism (Maybe LogEnv) (Maybe LogEnv) LogEnv LogEnv
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe LogEnv) (Maybe LogEnv) LogEnv LogEnv
-> Optic A_Lens NoIx LogEnv LogEnv x x
-> Optic' An_AffineTraversal NoIx (Maybe LogEnv) x
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx LogEnv LogEnv x x
#logNamespace))
  {-# INLINE labelOptic #-}

-- | Convenience function for retrieving a 'TBQueue'
-- 'NaviNote' from the @env@ and sending the note.
sendNoteQueue ::
  ( HasCallStack,
    HasNoteQueue env,
    MonadReader env m,
    MonadSTM m
  ) =>
  NaviNote ->
  m ()
sendNoteQueue :: forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue NaviNote
naviNote =
  (env -> TBQueue NaviNote) -> m (TBQueue NaviNote)
forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks env -> TBQueue NaviNote
forall (env :: OpticKind).
HasNoteQueue env =>
env -> TBQueue NaviNote
getNoteQueue m (TBQueue NaviNote) -> (TBQueue NaviNote -> m ()) -> m ()
forall (a :: OpticKind) (b :: OpticKind). m a -> (a -> m b) -> m b
forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= (TBQueue NaviNote -> NaviNote -> m ()
forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
TBQueue a -> a -> m ()
`writeTBQueueA` NaviNote
naviNote)
{-# INLINEABLE sendNoteQueue #-}