Default.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- |
Module      : GHC.Eventlog.Live.Otelcol.Config
Description : The implementation of @eventlog-live-otelcol@.
Stability   : experimental
Portability : portable
-}
module GHC.Eventlog.Live.Otelcol.Config.Default (
  defaultConfig,

  -- * Internal helpers for defining `Default` instances
  MissingDefaultException (..),
  getDefault,
) where

import Control.Exception (Exception (..), throw)
import Data.Bifunctor (Bifunctor (..))
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Proxy (Proxy (..))
import GHC.Eventlog.Live.Otelcol.Config.Default.Raw (decodeThrow, defaultConfigByteString)
import GHC.Eventlog.Live.Otelcol.Config.Types (Config)
import GHC.Records (HasField (..))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Lift.Compat (Exp, Lift (..), Q)

{- |
Internal helper.
The default configuration.
-}
defaultConfig :: Config
defaultConfig = $(lift =<< decodeThrow @Q @Config defaultConfigByteString)

{- |
__Warning:__ Compile-time only.

Internal helper.
This exception is thrown when a property is missing from the default configuration file.
-}
newtype MissingDefaultException
  = MissingDefaultException
  { accessors :: [String]
  }

instance Show MissingDefaultException where
  show :: MissingDefaultException -> String
  show e =
    "Missing property '" <> intercalate "." e.accessors <> "' in default configuration"

instance Exception MissingDefaultException

{- |
__Warning:__ Compile-time only.

Internal helper.
Get the default value under the given path of accessors and `lift` it.
-}
getDefault ::
  forall xs a b.
  (GetDefault xs a b, Lift b) =>
  a ->
  Q Exp
getDefault a = either throw lift (getDefaultEither @xs @a @b a)

{- |
__Warning:__ Compile-time only.

Internal helper.
Get the default value under the given accessor after calling a recursor.
This function is used to implement the `GetDefault` instances.
-}
getDefaultEither' ::
  forall x a b c.
  (KnownSymbol x, HasField x a (Maybe b)) =>
  (b -> Either MissingDefaultException c) ->
  a ->
  Either MissingDefaultException c
getDefaultEither' rec a =
  first addAccessor . maybe (Left $ MissingDefaultException []) rec $ getField @x a
 where
  addAccessor :: MissingDefaultException -> MissingDefaultException
  addAccessor e = MissingDefaultException{accessors = symbolVal (Proxy @x) : e.accessors}

{- |
__Warning:__ Compile-time only.

Internal helper.
This class guides the search for `getDefaultEither` functions from a list of accessors.
-}
class GetDefault (xs :: [Symbol]) (a :: Type) (b :: Type) where
  getDefaultEither :: a -> Either MissingDefaultException b

instance (KnownSymbol x, HasField x a (Maybe b)) => GetDefault (x ': '[]) a b where
  getDefaultEither :: a -> Either MissingDefaultException b
  getDefaultEither = getDefaultEither' @x Right
  {-# INLINE getDefaultEither #-}

instance (KnownSymbol x, HasField x a (Maybe b), GetDefault (y ': ys) b c) => GetDefault (x ': y ': ys) a c where
  getDefaultEither :: a -> Either MissingDefaultException c
  getDefaultEither = getDefaultEither' @x (getDefaultEither @(y ': ys))
  {-# INLINE getDefaultEither #-}