{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Debug.TraceEmbrace.Config.Load where

import Control.Concurrent
import Control.Exception
import Data.Cache.LRU as LRU
import Data.Char
import Data.Generics.Labels ()
import Data.IORef
import Data.List qualified as L
import Data.RadixTree.Word8.Strict qualified as T
import Data.Yaml as Y
import Debug.Trace (traceIO)
import Debug.TraceEmbrace.Config.Type
import Debug.TraceEmbrace.Config.Validation
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Refined
import System.Directory
import System.Environment (lookupEnv)
import System.IO
import System.IO.Unsafe


validateTraceMessageFormat ::
  String ->
  TraceMessageFormatMaybe ->
  Either String (Refined IdPred TraceMessageFormat)
validateTraceMessageFormat :: String
-> TraceMessageFormatMaybe
-> Either String (Refined IdPred TraceMessageFormat)
validateTraceMessageFormat String
fieldName TraceMessageFormatMaybe
ytc =
  String
-> TraceMessageFormat
-> Either String (Refined IdPred TraceMessageFormat)
forall {k} (p :: k) x.
Predicate p x =>
String -> x -> Either String (Refined p x)
refineS String
fieldName (TraceMessageFormat
 -> Either String (Refined IdPred TraceMessageFormat))
-> Either String TraceMessageFormat
-> Either String (Refined IdPred TraceMessageFormat)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Refined (And (SizeLessThan 5) NonEmpty) String
-> Refined (And (SizeLessThan 5) NonEmpty) String
-> Refined (And (SizeLessThan 5) NonEmpty) String
-> Refined NonEmpty [TraceMessageElement]
-> TraceMessageFormat
Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity NonEmpty [TraceMessageElement]
-> TraceMessageFormat
forall (a :: * -> *).
Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a NonEmpty [TraceMessageElement]
-> TraceMessageFormatG a
TraceMessageFormat
  (Refined (And (SizeLessThan 5) NonEmpty) String
 -> Refined (And (SizeLessThan 5) NonEmpty) String
 -> Refined (And (SizeLessThan 5) NonEmpty) String
 -> Refined NonEmpty [TraceMessageElement]
 -> TraceMessageFormat)
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
-> Either
     String
     (Refined (And (SizeLessThan 5) NonEmpty) String
      -> Refined (And (SizeLessThan 5) NonEmpty) String
      -> Refined NonEmpty [TraceMessageElement]
      -> TraceMessageFormat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Maybe String
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"entrySeparator" TraceMessageFormatMaybe
ytc.entrySeparator
  Either
  String
  (Refined (And (SizeLessThan 5) NonEmpty) String
   -> Refined (And (SizeLessThan 5) NonEmpty) String
   -> Refined NonEmpty [TraceMessageElement]
   -> TraceMessageFormat)
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
-> Either
     String
     (Refined (And (SizeLessThan 5) NonEmpty) String
      -> Refined NonEmpty [TraceMessageElement] -> TraceMessageFormat)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe String
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"keyValueSeparator" TraceMessageFormatMaybe
ytc.keyValueSeparator
  Either
  String
  (Refined (And (SizeLessThan 5) NonEmpty) String
   -> Refined NonEmpty [TraceMessageElement] -> TraceMessageFormat)
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
-> Either
     String
     (Refined NonEmpty [TraceMessageElement] -> TraceMessageFormat)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe String
-> Either String (Refined (And (SizeLessThan 5) NonEmpty) String)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"retValPrefix" TraceMessageFormatMaybe
ytc.retValPrefix
  Either
  String
  (Refined NonEmpty [TraceMessageElement] -> TraceMessageFormat)
-> Either String (Refined NonEmpty [TraceMessageElement])
-> Either String TraceMessageFormat
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe [TraceMessageElement]
-> Either String (Refined NonEmpty [TraceMessageElement])
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"traceLinePattern" TraceMessageFormatMaybe
ytc.traceLinePattern

validateYamlConfig :: YamlConfigMaybe -> Either String YamlConfig
validateYamlConfig :: YamlConfigMaybe -> Either String YamlConfig
validateYamlConfig YamlConfigMaybe
yc =
  Refined SinkModeP SinkMode
-> Refined (And (GreaterThan 0) (LessThan 2)) Int
-> Refined IdPred TraceMessageFormat
-> Refined HaskellModulePrefixP [LeveledModulePrefix]
-> Refined EnvironmentVariableP EnvironmentVariable
-> YamlConfig
Columnar Identity SinkModeP SinkMode
-> Columnar Identity (And (GreaterThan 0) (LessThan 2)) Int
-> Columnar Identity IdPred TraceMessageFormat
-> Columnar Identity HaskellModulePrefixP [LeveledModulePrefix]
-> Columnar Identity EnvironmentVariableP EnvironmentVariable
-> YamlConfig
forall (a :: * -> *).
Columnar a SinkModeP SinkMode
-> Columnar a (And (GreaterThan 0) (LessThan 2)) Int
-> Columnar a IdPred (TraceMessageFormatG a)
-> Columnar a HaskellModulePrefixP [LeveledModulePrefix]
-> Columnar a EnvironmentVariableP EnvironmentVariable
-> YamlConfigG a
YamlConfig
  (Refined SinkModeP SinkMode
 -> Refined (And (GreaterThan 0) (LessThan 2)) Int
 -> Refined IdPred TraceMessageFormat
 -> Refined HaskellModulePrefixP [LeveledModulePrefix]
 -> Refined EnvironmentVariableP EnvironmentVariable
 -> YamlConfig)
-> Either String (Refined SinkModeP SinkMode)
-> Either
     String
     (Refined (And (GreaterThan 0) (LessThan 2)) Int
      -> Refined IdPred TraceMessageFormat
      -> Refined HaskellModulePrefixP [LeveledModulePrefix]
      -> Refined EnvironmentVariableP EnvironmentVariable
      -> YamlConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Maybe SinkMode -> Either String (Refined SinkModeP SinkMode)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"mode" YamlConfigMaybe
yc.mode
  Either
  String
  (Refined (And (GreaterThan 0) (LessThan 2)) Int
   -> Refined IdPred TraceMessageFormat
   -> Refined HaskellModulePrefixP [LeveledModulePrefix]
   -> Refined EnvironmentVariableP EnvironmentVariable
   -> YamlConfig)
-> Either String (Refined (And (GreaterThan 0) (LessThan 2)) Int)
-> Either
     String
     (Refined IdPred TraceMessageFormat
      -> Refined HaskellModulePrefixP [LeveledModulePrefix]
      -> Refined EnvironmentVariableP EnvironmentVariable
      -> YamlConfig)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe Int
-> Either String (Refined (And (GreaterThan 0) (LessThan 2)) Int)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"version" YamlConfigMaybe
yc.version
  Either
  String
  (Refined IdPred TraceMessageFormat
   -> Refined HaskellModulePrefixP [LeveledModulePrefix]
   -> Refined EnvironmentVariableP EnvironmentVariable
   -> YamlConfig)
-> Either String (Refined IdPred TraceMessageFormat)
-> Either
     String
     (Refined HaskellModulePrefixP [LeveledModulePrefix]
      -> Refined EnvironmentVariableP EnvironmentVariable -> YamlConfig)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String
-> Maybe TraceMessageFormatMaybe
-> Either String (Refined IdPred TraceMessageFormatMaybe)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required  String
"traceMessage" YamlConfigMaybe
yc.traceMessage Either String (Refined IdPred TraceMessageFormatMaybe)
-> (Refined IdPred TraceMessageFormatMaybe
    -> Either String (Refined IdPred TraceMessageFormat))
-> Either String (Refined IdPred TraceMessageFormat)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       String
-> TraceMessageFormatMaybe
-> Either String (Refined IdPred TraceMessageFormat)
validateTraceMessageFormat String
"traceMessage" (TraceMessageFormatMaybe
 -> Either String (Refined IdPred TraceMessageFormat))
-> (Refined IdPred TraceMessageFormatMaybe
    -> TraceMessageFormatMaybe)
-> Refined IdPred TraceMessageFormatMaybe
-> Either String (Refined IdPred TraceMessageFormat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (p :: k) x. Refined p x -> x
forall p x. Refined p x -> x
unrefine @IdPred)
  Either
  String
  (Refined HaskellModulePrefixP [LeveledModulePrefix]
   -> Refined EnvironmentVariableP EnvironmentVariable -> YamlConfig)
-> Either
     String (Refined HaskellModulePrefixP [LeveledModulePrefix])
-> Either
     String
     (Refined EnvironmentVariableP EnvironmentVariable -> YamlConfig)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe [LeveledModulePrefix]
-> Either
     String (Refined HaskellModulePrefixP [LeveledModulePrefix])
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"levels" YamlConfigMaybe
yc.levels
  Either
  String
  (Refined EnvironmentVariableP EnvironmentVariable -> YamlConfig)
-> Either String (Refined EnvironmentVariableP EnvironmentVariable)
-> Either String YamlConfig
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> Maybe EnvironmentVariable
-> Either String (Refined EnvironmentVariableP EnvironmentVariable)
forall {k} {p :: k} {a}.
Predicate p a =>
String -> Maybe a -> Either String (Refined p a)
required String
"runtimeLevelsOverrideEnvVar" YamlConfigMaybe
yc.runtimeLevelsOverrideEnvVar

defaultTraceMessageFormatYaml :: TraceMessageFormatMaybe
defaultTraceMessageFormatYaml :: TraceMessageFormatMaybe
defaultTraceMessageFormatYaml = TraceMessageFormat
  { entrySeparator :: Columnar Maybe (And (SizeLessThan 5) NonEmpty) String
entrySeparator = String -> Maybe String
forall a. a -> Maybe a
Just String
"; "
  , keyValueSeparator :: Columnar Maybe (And (SizeLessThan 5) NonEmpty) String
keyValueSeparator = String -> Maybe String
forall a. a -> Maybe a
Just String
": "
  , retValPrefix :: Columnar Maybe (And (SizeLessThan 5) NonEmpty) String
retValPrefix = String -> Maybe String
forall a. a -> Maybe a
Just String
" => "
  , traceLinePattern :: Columnar Maybe NonEmpty [TraceMessageElement]
traceLinePattern =
    [TraceMessageElement] -> Maybe [TraceMessageElement]
forall a. a -> Maybe a
Just
    [ TraceMessageElement
FullyQualifiedModule
    , String -> TraceMessageElement
Delimiter String
"::"
    , TraceMessageElement
FunctionName
    , String -> TraceMessageElement
Delimiter String
": "
    , TraceMessageElement
LiteralMessage
    , TraceMessageElement
Variables
    ]
  }

defaultTraceMessageFormat :: TraceMessageFormat
defaultTraceMessageFormat :: TraceMessageFormat
defaultTraceMessageFormat =
  (String -> TraceMessageFormat)
-> (Refined IdPred TraceMessageFormat -> TraceMessageFormat)
-> Either String (Refined IdPred TraceMessageFormat)
-> TraceMessageFormat
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> TraceMessageFormat
forall a. HasCallStack => String -> a
error String
"defaultTraceMessageFormatYaml is partial") Refined IdPred TraceMessageFormat -> TraceMessageFormat
forall {k} (p :: k) x. Refined p x -> x
unrefine (Either String (Refined IdPred TraceMessageFormat)
 -> TraceMessageFormat)
-> Either String (Refined IdPred TraceMessageFormat)
-> TraceMessageFormat
forall a b. (a -> b) -> a -> b
$
    String
-> TraceMessageFormatMaybe
-> Either String (Refined IdPred TraceMessageFormat)
validateTraceMessageFormat String
"traceMessageFormat" TraceMessageFormatMaybe
defaultTraceMessageFormatYaml

newYamlConfig :: YamlConfigMaybe
newYamlConfig :: YamlConfigMaybe
newYamlConfig =
  YamlConfig
  { mode :: Columnar Maybe SinkModeP SinkMode
mode = SinkMode -> Maybe SinkMode
forall a. a -> Maybe a
Just SinkMode
TraceStd
  , version :: Columnar Maybe (And (GreaterThan 0) (LessThan 2)) Int
version = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  , traceMessage :: Columnar Maybe IdPred TraceMessageFormatMaybe
traceMessage = TraceMessageFormatMaybe -> Maybe TraceMessageFormatMaybe
forall a. a -> Maybe a
Just TraceMessageFormatMaybe
defaultTraceMessageFormatYaml
  , levels :: Columnar Maybe HaskellModulePrefixP [LeveledModulePrefix]
levels = [LeveledModulePrefix] -> Maybe [LeveledModulePrefix]
forall a. a -> Maybe a
Just [ TraceLevel -> Text -> LeveledModulePrefix
LeveledModulePrefix TraceLevel
Trace Text
"" ]
  , runtimeLevelsOverrideEnvVar :: Columnar Maybe EnvironmentVariableP EnvironmentVariable
runtimeLevelsOverrideEnvVar = EnvironmentVariable -> Maybe EnvironmentVariable
forall a. a -> Maybe a
Just EnvironmentVariable
CapsPackageName
  }

defaultYamlConfig :: YamlConfigMaybe
defaultYamlConfig :: YamlConfigMaybe
defaultYamlConfig = YamlConfigMaybe
newYamlConfig { version = Nothing }

loadYamlConfig :: IO YamlConfig
loadYamlConfig :: IO YamlConfig
loadYamlConfig = do
  String -> IO Bool
doesFileExist String
fp IO Bool -> (Bool -> IO YamlConfig) -> IO YamlConfig
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True ->
      YamlConfigMaybe -> IO YamlConfig
configFromJust (YamlConfigMaybe -> IO YamlConfig)
-> (YamlConfigMaybe -> YamlConfigMaybe)
-> YamlConfigMaybe
-> IO YamlConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YamlConfigMaybe -> YamlConfigMaybe -> YamlConfigMaybe
forall a. Semigroup a => a -> a -> a
<> YamlConfigMaybe
defaultYamlConfig) (YamlConfigMaybe -> IO YamlConfig)
-> IO YamlConfigMaybe -> IO YamlConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO YamlConfigMaybe
-> (ParseException -> IO YamlConfigMaybe) -> IO YamlConfigMaybe
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO YamlConfigMaybe
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Y.decodeFileThrow String
fp) ParseException -> IO YamlConfigMaybe
forall {m :: * -> *} {a}. MonadFail m => ParseException -> m a
badYaml
    Bool
False -> do
      IO () -> (ParseException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (do
                String -> YamlConfigMaybe -> IO ()
forall a. ToJSON a => String -> a -> IO ()
Y.encodeFile String
fp YamlConfigMaybe
newYamlConfig
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"New default config trace-embrace file is generated: [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]")
            (\ParseException
e -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to create config file [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] due: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
              ParseException -> String
prettyPrintParseException ParseException
e)
      YamlConfigMaybe -> IO YamlConfig
configFromJust YamlConfigMaybe
newYamlConfig
  where
    configFromJust :: YamlConfigMaybe -> IO YamlConfig
    configFromJust :: YamlConfigMaybe -> IO YamlConfig
configFromJust YamlConfigMaybe
ycm =
      (String -> IO YamlConfig)
-> (YamlConfig -> IO YamlConfig)
-> Either String YamlConfig
-> IO YamlConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
e -> String -> IO YamlConfig
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO YamlConfig) -> String -> IO YamlConfig
forall a b. (a -> b) -> a -> b
$ YamlConfigMaybe -> String
forall a. Show a => a -> String
show YamlConfigMaybe
ycm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nNot valid due: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e) YamlConfig -> IO YamlConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either String YamlConfig -> IO YamlConfig)
-> Either String YamlConfig -> IO YamlConfig
forall a b. (a -> b) -> a -> b
$ YamlConfigMaybe -> Either String YamlConfig
validateYamlConfig YamlConfigMaybe
ycm
    badYaml :: ParseException -> m a
badYaml ParseException
e =
      String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Fail to parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"file due:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
prettyPrintParseException ParseException
e
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nRename or delete existing config file to get default config."
    fp :: String
fp = String
traceEmbraceConfigFileName

traceEmbraceConfigFileName :: FilePath
traceEmbraceConfigFileName :: String
traceEmbraceConfigFileName = String
"trace-embrace.yaml"

traceEmbraceConfigRef :: IORef (Maybe TraceEmbraceConfig)
traceEmbraceConfigRef :: IORef (Maybe TraceEmbraceConfig)
traceEmbraceConfigRef = IO (IORef (Maybe TraceEmbraceConfig))
-> IORef (Maybe TraceEmbraceConfig)
forall a. IO a -> a
unsafePerformIO (Maybe TraceEmbraceConfig -> IO (IORef (Maybe TraceEmbraceConfig))
forall a. a -> IO (IORef a)
newIORef Maybe TraceEmbraceConfig
forall a. Maybe a
Nothing)
{-# NOINLINE traceEmbraceConfigRef #-}

unsafeIoSink :: IORef (Maybe Handle)
unsafeIoSink :: IORef (Maybe Handle)
unsafeIoSink = IO (IORef (Maybe Handle)) -> IORef (Maybe Handle)
forall a. IO a -> a
unsafePerformIO (Maybe Handle -> IO (IORef (Maybe Handle))
forall a. a -> IO (IORef a)
newIORef Maybe Handle
forall a. Maybe a
Nothing)
{-# NOINLINE unsafeIoSink #-}

newtype DynConfigEnvVar = DynConfigEnvVar String deriving (DynConfigEnvVar -> DynConfigEnvVar -> Bool
(DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> (DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> Eq DynConfigEnvVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
== :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
$c/= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
/= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
Eq, Int -> DynConfigEnvVar -> String -> String
[DynConfigEnvVar] -> String -> String
DynConfigEnvVar -> String
(Int -> DynConfigEnvVar -> String -> String)
-> (DynConfigEnvVar -> String)
-> ([DynConfigEnvVar] -> String -> String)
-> Show DynConfigEnvVar
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DynConfigEnvVar -> String -> String
showsPrec :: Int -> DynConfigEnvVar -> String -> String
$cshow :: DynConfigEnvVar -> String
show :: DynConfigEnvVar -> String
$cshowList :: [DynConfigEnvVar] -> String -> String
showList :: [DynConfigEnvVar] -> String -> String
Show, Eq DynConfigEnvVar
Eq DynConfigEnvVar =>
(DynConfigEnvVar -> DynConfigEnvVar -> Ordering)
-> (DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> (DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> (DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> (DynConfigEnvVar -> DynConfigEnvVar -> Bool)
-> (DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar)
-> (DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar)
-> Ord DynConfigEnvVar
DynConfigEnvVar -> DynConfigEnvVar -> Bool
DynConfigEnvVar -> DynConfigEnvVar -> Ordering
DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DynConfigEnvVar -> DynConfigEnvVar -> Ordering
compare :: DynConfigEnvVar -> DynConfigEnvVar -> Ordering
$c< :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
< :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
$c<= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
<= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
$c> :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
> :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
$c>= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
>= :: DynConfigEnvVar -> DynConfigEnvVar -> Bool
$cmax :: DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar
max :: DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar
$cmin :: DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar
min :: DynConfigEnvVar -> DynConfigEnvVar -> DynConfigEnvVar
Ord, (forall (m :: * -> *). Quote m => DynConfigEnvVar -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    DynConfigEnvVar -> Code m DynConfigEnvVar)
-> Lift DynConfigEnvVar
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => DynConfigEnvVar -> m Exp
forall (m :: * -> *).
Quote m =>
DynConfigEnvVar -> Code m DynConfigEnvVar
$clift :: forall (m :: * -> *). Quote m => DynConfigEnvVar -> m Exp
lift :: forall (m :: * -> *). Quote m => DynConfigEnvVar -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
DynConfigEnvVar -> Code m DynConfigEnvVar
liftTyped :: forall (m :: * -> *).
Quote m =>
DynConfigEnvVar -> Code m DynConfigEnvVar
Lift)

runtimeTraceEmbraceConfigRef :: MVar (LRU DynConfigEnvVar (T.StrictRadixTree TraceLevel))
runtimeTraceEmbraceConfigRef :: MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel))
runtimeTraceEmbraceConfigRef = IO (MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)))
-> MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel))
forall a. IO a -> a
unsafePerformIO (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> IO (MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)))
forall a. a -> IO (MVar a)
newMVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
 -> IO (MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel))))
-> LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> IO (MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)))
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
forall key val. Ord key => Maybe Integer -> LRU key val
newLRU (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
7))
{-# NOINLINE runtimeTraceEmbraceConfigRef #-}

mkPrefixTree :: [LeveledModulePrefix] -> T.StrictRadixTree TraceLevel
mkPrefixTree :: [LeveledModulePrefix] -> StrictRadixTree TraceLevel
mkPrefixTree = (StrictRadixTree TraceLevel
 -> LeveledModulePrefix -> StrictRadixTree TraceLevel)
-> StrictRadixTree TraceLevel
-> [LeveledModulePrefix]
-> StrictRadixTree TraceLevel
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' StrictRadixTree TraceLevel
-> LeveledModulePrefix -> StrictRadixTree TraceLevel
forall {r} {a}.
(HasField "level" r a, HasField "modulePrefix" r Text) =>
RadixTree a -> r -> RadixTree a
go StrictRadixTree TraceLevel
forall a. RadixTree a
T.empty
  where
    go :: RadixTree a -> r -> RadixTree a
go RadixTree a
b r
e = Feed -> a -> RadixTree a -> RadixTree a
forall a. Feed -> a -> RadixTree a -> RadixTree a
T.insert (Text -> Feed
T.feedText r
e.modulePrefix) r
e.level RadixTree a
b

yaml2Config :: YamlConfig -> TraceEmbraceConfig
yaml2Config :: YamlConfig -> TraceEmbraceConfig
yaml2Config YamlConfig
yc =
  SinkMode
-> TraceMessageFormat
-> StrictRadixTree TraceLevel
-> EnvironmentVariable
-> TraceEmbraceConfig
TraceEmbraceConfig (Refined SinkModeP SinkMode -> SinkMode
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined SinkModeP SinkMode -> SinkMode)
-> Refined SinkModeP SinkMode -> SinkMode
forall a b. (a -> b) -> a -> b
$ YamlConfig
yc.mode) (Refined IdPred TraceMessageFormat -> TraceMessageFormat
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined IdPred TraceMessageFormat -> TraceMessageFormat)
-> Refined IdPred TraceMessageFormat -> TraceMessageFormat
forall a b. (a -> b) -> a -> b
$ YamlConfig
yc.traceMessage)
  ([LeveledModulePrefix] -> StrictRadixTree TraceLevel
mkPrefixTree ([LeveledModulePrefix] -> StrictRadixTree TraceLevel)
-> (Refined HaskellModulePrefixP [LeveledModulePrefix]
    -> [LeveledModulePrefix])
-> Refined HaskellModulePrefixP [LeveledModulePrefix]
-> StrictRadixTree TraceLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined HaskellModulePrefixP [LeveledModulePrefix]
-> [LeveledModulePrefix]
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined HaskellModulePrefixP [LeveledModulePrefix]
 -> StrictRadixTree TraceLevel)
-> Refined HaskellModulePrefixP [LeveledModulePrefix]
-> StrictRadixTree TraceLevel
forall a b. (a -> b) -> a -> b
$ YamlConfig
yc.levels)
  (Refined EnvironmentVariableP EnvironmentVariable
-> EnvironmentVariable
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined EnvironmentVariableP EnvironmentVariable
 -> EnvironmentVariable)
-> Refined EnvironmentVariableP EnvironmentVariable
-> EnvironmentVariable
forall a b. (a -> b) -> a -> b
$ YamlConfig
yc.runtimeLevelsOverrideEnvVar)

configReadToken :: MVar ()
configReadToken :: MVar ()
configReadToken = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (() -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ())
{-# NOINLINE configReadToken #-}

getConfig :: Q TraceEmbraceConfig
getConfig :: Q TraceEmbraceConfig
getConfig = do
  c <- IO (Maybe TraceEmbraceConfig) -> Q (Maybe TraceEmbraceConfig)
forall a. IO a -> Q a
runIO IO (Maybe TraceEmbraceConfig)
readConfigRef Q (Maybe TraceEmbraceConfig)
-> (Maybe TraceEmbraceConfig -> Q TraceEmbraceConfig)
-> Q TraceEmbraceConfig
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TraceEmbraceConfig -> Q TraceEmbraceConfig
loadIfNothing
  runIO (doesFileExist traceEmbraceConfigFileName) >>= \case
    Bool
True -> String -> Q ()
addDependentFile String
traceEmbraceConfigFileName
    Bool
False -> String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Config File is missing - skip dependency"
  pure c
  where
    readConfigRef :: IO (Maybe TraceEmbraceConfig)
readConfigRef = IORef (Maybe TraceEmbraceConfig) -> IO (Maybe TraceEmbraceConfig)
forall a. IORef a -> IO a
readIORef IORef (Maybe TraceEmbraceConfig)
traceEmbraceConfigRef
    loadIfNothing :: Maybe TraceEmbraceConfig -> Q TraceEmbraceConfig
loadIfNothing = \case
      Maybe TraceEmbraceConfig
Nothing -> IO TraceEmbraceConfig -> Q TraceEmbraceConfig
forall a. IO a -> Q a
runIO (IO TraceEmbraceConfig -> Q TraceEmbraceConfig)
-> IO TraceEmbraceConfig -> Q TraceEmbraceConfig
forall a b. (a -> b) -> a -> b
$ do
        IO ()
-> (() -> IO ())
-> (() -> IO TraceEmbraceConfig)
-> IO TraceEmbraceConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
configReadToken)
          (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
configReadToken)
          (\() ->
             IO (Maybe TraceEmbraceConfig)
readConfigRef IO (Maybe TraceEmbraceConfig)
-> (Maybe TraceEmbraceConfig -> IO TraceEmbraceConfig)
-> IO TraceEmbraceConfig
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Just TraceEmbraceConfig
c ->
                 TraceEmbraceConfig -> IO TraceEmbraceConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceEmbraceConfig
c
               Maybe TraceEmbraceConfig
Nothing -> do
                 c <- YamlConfig -> TraceEmbraceConfig
yaml2Config (YamlConfig -> TraceEmbraceConfig)
-> IO YamlConfig -> IO TraceEmbraceConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO YamlConfig
loadYamlConfig
                 (atomicWriteIORef traceEmbraceConfigRef (Just c))
                 pure c)
      Just TraceEmbraceConfig
c -> TraceEmbraceConfig -> Q TraceEmbraceConfig
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceEmbraceConfig
c

traceAll :: [LeveledModulePrefix]
traceAll :: [LeveledModulePrefix]
traceAll = TraceLevel -> [LeveledModulePrefix]
emptyPrefixTraceLevel TraceLevel
Trace

emptyPrefixTraceLevel :: TraceLevel -> [LeveledModulePrefix]
emptyPrefixTraceLevel :: TraceLevel -> [LeveledModulePrefix]
emptyPrefixTraceLevel TraceLevel
tl =
  [ LeveledModulePrefix
    { level :: TraceLevel
level = TraceLevel
tl
    , modulePrefix :: Text
modulePrefix = Text
""
    }
  ]

loadRuntimeConfig :: DynConfigEnvVar -> IO (T.StrictRadixTree TraceLevel)
loadRuntimeConfig :: DynConfigEnvVar -> IO (StrictRadixTree TraceLevel)
loadRuntimeConfig (DynConfigEnvVar String
evar) = do
  String -> IO (Maybe String)
lookupEnv String
evar IO (Maybe String)
-> (Maybe String -> IO (StrictRadixTree TraceLevel))
-> IO (StrictRadixTree TraceLevel)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> StrictRadixTree TraceLevel -> IO (StrictRadixTree TraceLevel)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictRadixTree TraceLevel -> IO (StrictRadixTree TraceLevel))
-> StrictRadixTree TraceLevel -> IO (StrictRadixTree TraceLevel)
forall a b. (a -> b) -> a -> b
$ [LeveledModulePrefix] -> StrictRadixTree TraceLevel
mkPrefixTree [LeveledModulePrefix]
traceAll
    Just String
"" -> StrictRadixTree TraceLevel -> IO (StrictRadixTree TraceLevel)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictRadixTree TraceLevel
forall a. RadixTree a
T.empty
    Just String
"-" -> StrictRadixTree TraceLevel -> IO (StrictRadixTree TraceLevel)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictRadixTree TraceLevel
forall a. RadixTree a
T.empty
    Just String
fp -> [LeveledModulePrefix] -> StrictRadixTree TraceLevel
mkPrefixTree ([LeveledModulePrefix] -> StrictRadixTree TraceLevel)
-> IO [LeveledModulePrefix] -> IO (StrictRadixTree TraceLevel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [LeveledModulePrefix]
loadRuntimeConfigFromYamlFile String
fp

loadRuntimeConfigFromYamlFile :: FilePath -> IO [LeveledModulePrefix]
loadRuntimeConfigFromYamlFile :: String -> IO [LeveledModulePrefix]
loadRuntimeConfigFromYamlFile [] = [LeveledModulePrefix] -> IO [LeveledModulePrefix]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- disable all logs
loadRuntimeConfigFromYamlFile String
fp =
  String -> IO Bool
doesFileExist String
fp IO Bool
-> (Bool -> IO [LeveledModulePrefix]) -> IO [LeveledModulePrefix]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True ->
      IO [LeveledModulePrefix]
-> (ParseException -> IO [LeveledModulePrefix])
-> IO [LeveledModulePrefix]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO [LeveledModulePrefix]
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Y.decodeFileThrow String
fp) ParseException -> IO [LeveledModulePrefix]
badYaml IO [LeveledModulePrefix] -> IO () -> IO [LeveledModulePrefix]
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (String -> IO ()
traceIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"trace-embrace runtime config loaded from "
                                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp)
    Bool
False -> do
      String -> IO ()
traceIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"trace-embrace runtime config file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is missing - disable tracing"
      [LeveledModulePrefix] -> IO [LeveledModulePrefix]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LeveledModulePrefix]
traceAll
  where
    badYaml :: ParseException -> IO [LeveledModulePrefix]
badYaml ParseException
e =
      String -> IO [LeveledModulePrefix]
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [LeveledModulePrefix])
-> String -> IO [LeveledModulePrefix]
forall a b. (a -> b) -> a -> b
$ String
"Fail to parse trace-embrace runtime config from file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" due:\n"
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
prettyPrintParseException ParseException
e

getRuntimeConfig :: DynConfigEnvVar -> IO (T.StrictRadixTree TraceLevel)
getRuntimeConfig :: DynConfigEnvVar -> IO (StrictRadixTree TraceLevel)
getRuntimeConfig DynConfigEnvVar
evar = MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel))
-> (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
    -> IO
         (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
          StrictRadixTree TraceLevel))
-> IO (StrictRadixTree TraceLevel)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (LRU DynConfigEnvVar (StrictRadixTree TraceLevel))
runtimeTraceEmbraceConfigRef LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> IO
     (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
      StrictRadixTree TraceLevel)
go
  where
    go :: LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> IO
     (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
      StrictRadixTree TraceLevel)
go LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
lru =
      case DynConfigEnvVar
-> LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
    Maybe (StrictRadixTree TraceLevel))
forall key val.
Ord key =>
key -> LRU key val -> (LRU key val, Maybe val)
LRU.lookup DynConfigEnvVar
evar LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
lru of
        (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
lru', Just StrictRadixTree TraceLevel
dynCon) -> (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
 StrictRadixTree TraceLevel)
-> IO
     (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
      StrictRadixTree TraceLevel)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
lru', StrictRadixTree TraceLevel
dynCon)
        (LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
_, Maybe (StrictRadixTree TraceLevel)
Nothing) -> DynConfigEnvVar -> IO (StrictRadixTree TraceLevel)
loadRuntimeConfig DynConfigEnvVar
evar IO (StrictRadixTree TraceLevel)
-> (StrictRadixTree TraceLevel
    -> IO
         (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
          StrictRadixTree TraceLevel))
-> IO
     (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
      StrictRadixTree TraceLevel)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          \StrictRadixTree TraceLevel
c -> (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
 StrictRadixTree TraceLevel)
-> IO
     (LRU DynConfigEnvVar (StrictRadixTree TraceLevel),
      StrictRadixTree TraceLevel)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynConfigEnvVar
-> StrictRadixTree TraceLevel
-> LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
-> LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
forall key val. Ord key => key -> val -> LRU key val -> LRU key val
LRU.insert DynConfigEnvVar
evar StrictRadixTree TraceLevel
c LRU DynConfigEnvVar (StrictRadixTree TraceLevel)
lru, StrictRadixTree TraceLevel
c)

markerConfig :: TraceEmbraceConfig
markerConfig :: TraceEmbraceConfig
markerConfig = TraceEmbraceConfig
    { mode :: SinkMode
mode = SinkMode
TraceEvent
    , traceMessage :: TraceMessageFormat
traceMessage =
        Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity (And (SizeLessThan 5) NonEmpty) String
-> Columnar Identity NonEmpty [TraceMessageElement]
-> TraceMessageFormat
forall (a :: * -> *).
Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a (And (SizeLessThan 5) NonEmpty) String
-> Columnar a NonEmpty [TraceMessageElement]
-> TraceMessageFormatG a
TraceMessageFormat
        ($$(refineTH "e") :: Refined SeparatorValidator String)
        ($$(refineTH "e") :: Refined SeparatorValidator String)
        ($$(refineTH "e") :: Refined SeparatorValidator String)
        ($$(refineTH [ ModuleName, Delimiter "::", FunctionName ]) :: Refined NonEmpty [TraceMessageElement])
    , levels :: StrictRadixTree TraceLevel
levels = [LeveledModulePrefix] -> StrictRadixTree TraceLevel
mkPrefixTree [LeveledModulePrefix]
traceAll
    , runtimeLevelsOverrideEnvVar :: EnvironmentVariable
runtimeLevelsOverrideEnvVar = EnvironmentVariable
Ignored
    }

envVarName :: Loc -> EnvironmentVariable -> Maybe DynConfigEnvVar
envVarName :: Loc -> EnvironmentVariable -> Maybe DynConfigEnvVar
envVarName Loc
loc = (String -> DynConfigEnvVar)
-> Maybe String -> Maybe DynConfigEnvVar
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> DynConfigEnvVar
DynConfigEnvVar (Maybe String -> Maybe DynConfigEnvVar)
-> (EnvironmentVariable -> Maybe String)
-> EnvironmentVariable
-> Maybe DynConfigEnvVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  EnvironmentVariable
Ignored -> Maybe String
forall a. Maybe a
Nothing
  EnvironmentVariable
CapsPackageName ->
    String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
packageBasedEnvVarPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropSuffix
    (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Char -> Char
toUpper (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
underscoreNonAlphaNum
    (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> String
loc_package Loc
loc
  EnvironmentVariable String
evar -> String -> Maybe String
forall a. a -> Maybe a
Just String
evar
  where
    dropSuffix :: String -> String
dropSuffix (Char
'_':Char
h:String
t)
       | Char -> Bool
isDigit Char
h = []
       | Bool
otherwise = Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
dropSuffix (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t)
    dropSuffix (Char
o:String
t) =  Char
o Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
dropSuffix String
t
    dropSuffix [] = []

    underscoreNonAlphaNum :: Char -> Char
underscoreNonAlphaNum Char
c
      | Char -> Bool
isAlphaNum Char
c = Char
c
      | Bool
otherwise = Char
'_'