{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module provides way to get option values from different sources:
--
--     - the command line
--     - the system environment variables
--     - a YAML configuration file
--
--   A registry is used to bring some extensibility:
--
--     - change the configuration file name
--     - change the mapping between option names and environment variable names
--     - change the mapping between options names and yaml names
--
--  Here is an example:
--
--  getLexemesWith (
--    -- restrict the env / config file search to the options of a given parser
--    setOptionNames (getOptionNames parser) .
--    -- change the config file path
--    setConfigFilePath "~/.config" .
--    -- change the config for retrieving environment variables based on option names
--    setEnvironmentNames env1 .
--    -- change the config for retrieving yaml values based on option names
--    setYamlNames yaml1 .
--    -- set command line arguments instead of taking them from getArgs
--    setArguments args .
--    -- set the priorities for the option values
--    setPriorities [commandLineSource, yamlSource])
module Data.Registry.Options.Sources where

import Data.ByteString qualified as BS
import Data.List qualified as L
import Data.Map qualified as M
import Data.Registry
import Data.Registry.Options.Lexemes hiding (getArguments)
import Data.Registry.Options.Text
import Data.Text qualified as T
import Data.YAML
import Protolude
import System.Environment (getEnvironment, lookupEnv)

-- | Get lexemes
getLexemes :: MonadIO m => m Lexemes
getLexemes :: forall (m :: * -> *). MonadIO m => m Lexemes
getLexemes = (Registry
   '[IO Priorities, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
     IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
   '[IO Lexemes, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
     IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
 -> Registry
      '[IO Priorities, IO (Tag "environment" Lexemes),
        IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
        IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
        IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
      '[IO Lexemes, IO (Tag "environment" Lexemes),
        IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
        IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
        IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)])
-> m Lexemes
forall (m :: * -> *) {ins :: [*]} {out :: [*]}.
MonadIO m =>
(Registry
   '[IO Priorities, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
     IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
   '[IO Lexemes, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
     IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
 -> Registry ins out)
-> m Lexemes
getLexemesWith (Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO Priorities, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
       IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
     '[IO Lexemes, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO Priorities, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
       IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
     '[IO Lexemes, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b. a -> b -> a
const Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
sources)

-- | Get lexemes with a modified registry
getLexemesWith :: MonadIO m => (Registry _ _ -> Registry _ _) -> m  Lexemes
getLexemesWith :: (Registry
   '[IO Priorities, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
     IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
   '[IO Lexemes, IO (Tag "environment" Lexemes),
     IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
     IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
     IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
 -> Registry ins out)
-> m Lexemes
getLexemesWith Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry ins out
f = IO Lexemes -> m Lexemes
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Lexemes -> m Lexemes) -> IO Lexemes -> m Lexemes
forall a b. (a -> b) -> a -> b
$ forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(IO Lexemes) (Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry ins out
f Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
sources)

-- | Set option names on the registry
setOptionNames :: [Text] -> Registry _ _ -> Registry _ _
setOptionNames :: [Text] -> Registry w out -> Registry w (IO OptionNames : out)
setOptionNames [Text]
names Registry w out
r = forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO ([Text] -> OptionNames
OptionNames [Text]
names) Typed (IO OptionNames)
-> Registry w out
-> Registry
     (Inputs (IO OptionNames) :++ w) (Output (IO OptionNames) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Set the config file path
setConfigFilePath :: Text -> Registry _ _ -> Registry _ _
setConfigFilePath :: Text -> Registry w out -> Registry w (IO (Maybe YamlPath) : out)
setConfigFilePath Text
path Registry w out
r = forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO (YamlPath -> Maybe YamlPath
forall a. a -> Maybe a
Just (YamlPath -> Maybe YamlPath) -> YamlPath -> Maybe YamlPath
forall a b. (a -> b) -> a -> b
$ Text -> YamlPath
YamlPath Text
path) Typed (IO (Maybe YamlPath))
-> Registry w out
-> Registry
     (Inputs (IO (Maybe YamlPath)) :++ w)
     (Output (IO (Maybe YamlPath)) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Set the configuration for environment names
setEnvironmentNames :: EnvironmentNames -> Registry _ _ -> Registry _ _
setEnvironmentNames :: EnvironmentNames
-> Registry ins out
-> Registry
     (Inputs (IO EnvironmentNames) :++ ins)
     (Output (IO EnvironmentNames) : out)
setEnvironmentNames EnvironmentNames
names Registry ins out
r = forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO EnvironmentNames
names Typed (IO EnvironmentNames)
-> Registry ins out
-> Registry
     (Inputs (IO EnvironmentNames) :++ ins)
     (Output (IO EnvironmentNames) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry ins out
r

-- | Set the configuration for yaml names
setYamlNames :: YamlNames -> Registry _ _ -> Registry _ _
setYamlNames :: YamlNames
-> Registry ins out
-> Registry
     (Inputs (IO YamlNames) :++ ins) (Output (IO YamlNames) : out)
setYamlNames YamlNames
names Registry ins out
r = forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO YamlNames
names Typed (IO YamlNames)
-> Registry ins out
-> Registry
     (Inputs (IO YamlNames) :++ ins) (Output (IO YamlNames) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry ins out
r

-- | Set arguments as if they were read from the command line
setArguments :: [Text] -> Registry _ _ -> Registry _ _
setArguments :: [Text] -> Registry w out -> Registry w (IO Arguments : out)
setArguments [Text]
args Registry w out
r = forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO ([Text] -> Arguments
Arguments [Text]
args) Typed (IO Arguments)
-> Registry w out
-> Registry
     (Inputs (IO Arguments) :++ w) (Output (IO Arguments) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Set source priorities
setPriorities :: [Source] -> Registry _ _ -> Registry _ _
setPriorities :: [Source] -> Registry w out -> Registry w (IO Priorities : out)
setPriorities [Source]
ps Registry w out
r = forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO ([Source] -> Priorities
Priorities [Source]
ps) Typed (IO Priorities)
-> Registry w out
-> Registry
     (Inputs (IO Priorities) :++ w) (Output (IO Priorities) : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
+: Registry w out
r

-- | Registry allowing the retrieval of Lexemes from various sources: command line, environment variable, configuration file
sources :: Registry _ _
sources :: Registry
  '[IO Priorities, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
    IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
  '[IO Lexemes, IO (Tag "environment" Lexemes),
    IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
    IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
    IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
sources =
  forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO Priorities
-> Tag "environment" Lexemes
-> Tag "yaml" Lexemes
-> Tag "commandline" Lexemes
-> Lexemes
selectValues
    Typed
  (IO Priorities
   -> IO (Tag "environment" Lexemes)
   -> IO (Tag "yaml" Lexemes)
   -> IO (Tag "commandline" Lexemes)
   -> IO Lexemes)
-> Registry
     '[IO OptionNames, IO EnvironmentNames, IO YamlNames,
       IO OptionNames, IO (Maybe YamlByteString), IO Arguments,
       IO (Maybe YamlPath)]
     '[IO (Tag "environment" Lexemes), IO (Tag "yaml" Lexemes),
       IO (Tag "commandline" Lexemes), IO Priorities, IO Arguments,
       IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO Priorities, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO OptionNames, IO EnvironmentNames, IO YamlNames, IO OptionNames,
       IO (Maybe YamlByteString), IO Arguments, IO (Maybe YamlPath)]
     '[IO Lexemes, IO (Tag "environment" Lexemes),
       IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO OptionNames -> EnvironmentNames -> IO (Tag "environment" Lexemes)
getValuesFromEnvironment
    Typed
  (IO OptionNames
   -> IO EnvironmentNames -> IO (Tag "environment" Lexemes))
-> Registry
     '[IO YamlNames, IO OptionNames, IO (Maybe YamlByteString),
       IO Arguments, IO (Maybe YamlPath)]
     '[IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO OptionNames, IO EnvironmentNames, IO YamlNames,
       IO OptionNames, IO (Maybe YamlByteString), IO Arguments,
       IO (Maybe YamlPath)]
     '[IO (Tag "environment" Lexemes), IO (Tag "yaml" Lexemes),
       IO (Tag "commandline" Lexemes), IO Priorities, IO Arguments,
       IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO YamlNames
-> OptionNames -> Maybe YamlByteString -> IO (Tag "yaml" Lexemes)
getValuesFromYaml
    Typed
  (IO YamlNames
   -> IO OptionNames
   -> IO (Maybe YamlByteString)
   -> IO (Tag "yaml" Lexemes))
-> Registry
     '[IO Arguments, IO (Maybe YamlPath)]
     '[IO (Tag "commandline" Lexemes), IO Priorities, IO Arguments,
       IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO YamlNames, IO OptionNames, IO (Maybe YamlByteString),
       IO Arguments, IO (Maybe YamlPath)]
     '[IO (Tag "yaml" Lexemes), IO (Tag "commandline" Lexemes),
       IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO Arguments -> Tag "commandline" Lexemes
getValuesFromCommandLine
    Typed (IO Arguments -> IO (Tag "commandline" Lexemes))
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO Arguments, IO (Maybe YamlPath)]
     '[IO (Tag "commandline" Lexemes), IO Priorities, IO Arguments,
       IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO Priorities
defaultPriorities
    Typed (IO Priorities)
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO Priorities, IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: IO Arguments -> Typed (IO Arguments)
forall a. Typeable a => a -> Typed a
fun IO Arguments
getCommandlineArguments
    Typed (IO Arguments)
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO Arguments, IO EnvironmentNames, IO YamlNames,
       IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO EnvironmentNames
defaultEnvironmentNames
    Typed (IO EnvironmentNames)
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO YamlNames, IO (Maybe YamlByteString), IO OptionNames,
       IO (Maybe YamlPath)]
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO EnvironmentNames, IO YamlNames, IO (Maybe YamlByteString),
       IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO YamlNames
defaultYamlNames
    Typed (IO YamlNames)
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO YamlNames, IO (Maybe YamlByteString), IO OptionNames,
       IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @IO Maybe YamlPath -> IO (Maybe YamlByteString)
readYamlFile
    Typed (IO (Maybe YamlPath) -> IO (Maybe YamlByteString))
-> Registry '[] '[IO OptionNames, IO (Maybe YamlPath)]
-> Registry
     '[IO (Maybe YamlPath)]
     '[IO (Maybe YamlByteString), IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO (OptionNames
forall a. Monoid a => a
mempty :: OptionNames)
    Typed (IO OptionNames)
-> Typed (IO (Maybe YamlPath))
-> Registry '[] '[IO OptionNames, IO (Maybe YamlPath)]
forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo @IO Maybe YamlPath
defaultYamlPath

-- | List of option names defined in a parser
--   It is used to restrict the names parsed in environment variables or in a configuration file
newtype OptionNames = OptionNames {OptionNames -> [Text]
_optionNames :: [Text]} deriving (OptionNames -> OptionNames -> Bool
(OptionNames -> OptionNames -> Bool)
-> (OptionNames -> OptionNames -> Bool) -> Eq OptionNames
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OptionNames -> OptionNames -> Bool
$c/= :: OptionNames -> OptionNames -> Bool
== :: OptionNames -> OptionNames -> Bool
$c== :: OptionNames -> OptionNames -> Bool
Eq, Int -> OptionNames -> ShowS
[OptionNames] -> ShowS
OptionNames -> String
(Int -> OptionNames -> ShowS)
-> (OptionNames -> String)
-> ([OptionNames] -> ShowS)
-> Show OptionNames
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OptionNames] -> ShowS
$cshowList :: [OptionNames] -> ShowS
show :: OptionNames -> String
$cshow :: OptionNames -> String
showsPrec :: Int -> OptionNames -> ShowS
$cshowsPrec :: Int -> OptionNames -> ShowS
Show, NonEmpty OptionNames -> OptionNames
OptionNames -> OptionNames -> OptionNames
(OptionNames -> OptionNames -> OptionNames)
-> (NonEmpty OptionNames -> OptionNames)
-> (forall b. Integral b => b -> OptionNames -> OptionNames)
-> Semigroup OptionNames
forall b. Integral b => b -> OptionNames -> OptionNames
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> OptionNames -> OptionNames
$cstimes :: forall b. Integral b => b -> OptionNames -> OptionNames
sconcat :: NonEmpty OptionNames -> OptionNames
$csconcat :: NonEmpty OptionNames -> OptionNames
<> :: OptionNames -> OptionNames -> OptionNames
$c<> :: OptionNames -> OptionNames -> OptionNames
Semigroup, Semigroup OptionNames
OptionNames
Semigroup OptionNames
-> OptionNames
-> (OptionNames -> OptionNames -> OptionNames)
-> ([OptionNames] -> OptionNames)
-> Monoid OptionNames
[OptionNames] -> OptionNames
OptionNames -> OptionNames -> OptionNames
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [OptionNames] -> OptionNames
$cmconcat :: [OptionNames] -> OptionNames
mappend :: OptionNames -> OptionNames -> OptionNames
$cmappend :: OptionNames -> OptionNames -> OptionNames
mempty :: OptionNames
$cmempty :: OptionNames
Monoid)

-- | Select lexed option names / values according to user defined priorities
selectValues :: Priorities -> Tag "environment" Lexemes -> Tag "yaml" Lexemes -> Tag "commandline" Lexemes -> Lexemes
selectValues :: Priorities
-> Tag "environment" Lexemes
-> Tag "yaml" Lexemes
-> Tag "commandline" Lexemes
-> Lexemes
selectValues Priorities
priorities Tag "environment" Lexemes
env Tag "yaml" Lexemes
yaml Tag "commandline" Lexemes
cl = do
  let bySource :: [(Source, Lexemes)]
bySource = [(Source
environmentSource, Tag "environment" Lexemes -> Lexemes
forall (s :: Symbol) a. Tag s a -> a
unTag Tag "environment" Lexemes
env), (Source
yamlSource, Tag "yaml" Lexemes -> Lexemes
forall (s :: Symbol) a. Tag s a -> a
unTag Tag "yaml" Lexemes
yaml), (Source
commandLineSource, Tag "commandline" Lexemes -> Lexemes
forall (s :: Symbol) a. Tag s a -> a
unTag Tag "commandline" Lexemes
cl)]
  (Lexemes -> Lexemes -> Lexemes) -> Lexemes -> [Lexemes] -> Lexemes
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Lexemes -> Lexemes -> Lexemes
override Lexemes
forall a. Monoid a => a
mempty ([Lexemes] -> [Lexemes]
forall a. [a] -> [a]
reverse ([Lexemes] -> [Lexemes]) -> [Lexemes] -> [Lexemes]
forall a b. (a -> b) -> a -> b
$ Priorities -> [(Source, Lexemes)] -> [Lexemes]
forall a. Priorities -> [(Source, a)] -> [a]
sortBySource Priorities
priorities [(Source, Lexemes)]
bySource)

-- * Command line

-- | Lex the arguments coming from the command line
getValuesFromCommandLine :: Arguments -> Tag "commandline" Lexemes
getValuesFromCommandLine :: Arguments -> Tag "commandline" Lexemes
getValuesFromCommandLine = Lexemes -> Tag "commandline" Lexemes
forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (Lexemes -> Tag "commandline" Lexemes)
-> (Arguments -> Lexemes) -> Arguments -> Tag "commandline" Lexemes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Lexemes
lexArgs ([Text] -> Lexemes)
-> (Arguments -> [Text]) -> Arguments -> Lexemes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments -> [Text]
_arguments

-- | By default arguments are retrieved from the base 'getArgs' function
getCommandlineArguments :: IO Arguments
getCommandlineArguments :: IO Arguments
getCommandlineArguments = [Text] -> Arguments
Arguments ([Text] -> Arguments)
-> ([String] -> [Text]) -> [String] -> Arguments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a b. ConvertText a b => a -> b
toS ([String] -> Arguments) -> IO [String] -> IO Arguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs

-- | List of strings retrieved from the command line
newtype Arguments = Arguments {Arguments -> [Text]
_arguments :: [Text]} deriving (Arguments -> Arguments -> Bool
(Arguments -> Arguments -> Bool)
-> (Arguments -> Arguments -> Bool) -> Eq Arguments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arguments -> Arguments -> Bool
$c/= :: Arguments -> Arguments -> Bool
== :: Arguments -> Arguments -> Bool
$c== :: Arguments -> Arguments -> Bool
Eq, Int -> Arguments -> ShowS
[Arguments] -> ShowS
Arguments -> String
(Int -> Arguments -> ShowS)
-> (Arguments -> String)
-> ([Arguments] -> ShowS)
-> Show Arguments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arguments] -> ShowS
$cshowList :: [Arguments] -> ShowS
show :: Arguments -> String
$cshow :: Arguments -> String
showsPrec :: Int -> Arguments -> ShowS
$cshowsPrec :: Int -> Arguments -> ShowS
Show, NonEmpty Arguments -> Arguments
Arguments -> Arguments -> Arguments
(Arguments -> Arguments -> Arguments)
-> (NonEmpty Arguments -> Arguments)
-> (forall b. Integral b => b -> Arguments -> Arguments)
-> Semigroup Arguments
forall b. Integral b => b -> Arguments -> Arguments
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Arguments -> Arguments
$cstimes :: forall b. Integral b => b -> Arguments -> Arguments
sconcat :: NonEmpty Arguments -> Arguments
$csconcat :: NonEmpty Arguments -> Arguments
<> :: Arguments -> Arguments -> Arguments
$c<> :: Arguments -> Arguments -> Arguments
Semigroup, Semigroup Arguments
Arguments
Semigroup Arguments
-> Arguments
-> (Arguments -> Arguments -> Arguments)
-> ([Arguments] -> Arguments)
-> Monoid Arguments
[Arguments] -> Arguments
Arguments -> Arguments -> Arguments
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Arguments] -> Arguments
$cmconcat :: [Arguments] -> Arguments
mappend :: Arguments -> Arguments -> Arguments
$cmappend :: Arguments -> Arguments -> Arguments
mempty :: Arguments
$cmempty :: Arguments
Monoid)

-- * Environment

-- | Get values from the environment
getValuesFromEnvironment :: OptionNames -> EnvironmentNames -> IO (Tag "environment" Lexemes)
getValuesFromEnvironment :: OptionNames -> EnvironmentNames -> IO (Tag "environment" Lexemes)
getValuesFromEnvironment (OptionNames []) EnvironmentNames
ens = do
  [Lexemes]
lexemes <- ((String, String) -> Lexemes) -> [(String, String)] -> [Lexemes]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
n, String
v) -> Text -> Text -> Lexemes
optionLexemes (EnvironmentNames -> Text -> Text
fromEnvironmentName EnvironmentNames
ens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertText a b => a -> b
toS String
n) (String -> Text
forall a b. ConvertText a b => a -> b
toS String
v)) ([(String, String)] -> [Lexemes])
-> IO [(String, String)] -> IO [Lexemes]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  Tag "environment" Lexemes -> IO (Tag "environment" Lexemes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tag "environment" Lexemes -> IO (Tag "environment" Lexemes))
-> (Lexemes -> Tag "environment" Lexemes)
-> Lexemes
-> IO (Tag "environment" Lexemes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexemes -> Tag "environment" Lexemes
forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (Lexemes -> IO (Tag "environment" Lexemes))
-> Lexemes -> IO (Tag "environment" Lexemes)
forall a b. (a -> b) -> a -> b
$ [Lexemes] -> Lexemes
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Lexemes]
lexemes
getValuesFromEnvironment (OptionNames [Text]
os) EnvironmentNames
ens = do
  [Lexemes]
lexemes <- [Text] -> (Text -> IO Lexemes) -> IO [Lexemes]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Text]
os ((Text -> IO Lexemes) -> IO [Lexemes])
-> (Text -> IO Lexemes) -> IO [Lexemes]
forall a b. (a -> b) -> a -> b
$ \Text
o -> Lexemes -> (String -> Lexemes) -> Maybe String -> Lexemes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Lexemes
forall a. Monoid a => a
mempty (Text -> Text -> Lexemes
optionLexemes Text
o (Text -> Lexemes) -> (String -> Text) -> String -> Lexemes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS) (Maybe String -> Lexemes) -> IO (Maybe String) -> IO Lexemes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EnvironmentNames -> Text -> Text
toEnvironmentName EnvironmentNames
ens Text
o)
  Tag "environment" Lexemes -> IO (Tag "environment" Lexemes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tag "environment" Lexemes -> IO (Tag "environment" Lexemes))
-> (Lexemes -> Tag "environment" Lexemes)
-> Lexemes
-> IO (Tag "environment" Lexemes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexemes -> Tag "environment" Lexemes
forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (Lexemes -> IO (Tag "environment" Lexemes))
-> Lexemes -> IO (Tag "environment" Lexemes)
forall a b. (a -> b) -> a -> b
$ [Lexemes] -> Lexemes
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Lexemes]
lexemes

-- | Configuration for transforming an environment name into an option name
--   and for transforming an option name into an environment name
data EnvironmentNames = EnvironmentNames
  { EnvironmentNames -> Text -> Text
fromEnvironmentName :: Text -> Text,
    EnvironmentNames -> Text -> Text
toEnvironmentName :: Text -> Text
  }

-- | Default conversion functions for environment variables names to option names
--  @fromEnvironmentName "OPTION_NAME" == "optionName"@
--  @toEnvironmentName "optionName" == "OPTION_NAME"@
defaultEnvironmentNames :: EnvironmentNames
defaultEnvironmentNames :: EnvironmentNames
defaultEnvironmentNames =
  EnvironmentNames
    { fromEnvironmentName :: Text -> Text
fromEnvironmentName = Text -> Text
underscoreToHyphenated (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower,
      toEnvironmentName :: Text -> Text
toEnvironmentName = Text -> Text
T.toUpper (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphenatedToUnderscore
    }

-- * Yaml

-- | Values can be retrieved from a Yaml file
getValuesFromYaml :: YamlNames -> OptionNames -> Maybe YamlByteString -> IO (Tag "yaml" Lexemes)
getValuesFromYaml :: YamlNames
-> OptionNames -> Maybe YamlByteString -> IO (Tag "yaml" Lexemes)
getValuesFromYaml YamlNames
_ OptionNames
_ Maybe YamlByteString
Nothing = Tag "yaml" Lexemes -> IO (Tag "yaml" Lexemes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lexemes -> Apply (Tag "yaml") (CountArgs Lexemes) Lexemes
forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (Lexemes
forall a. Monoid a => a
mempty :: Lexemes))
getValuesFromYaml YamlNames
yns OptionNames
optionNames (Just (YamlByteString ByteString
bs)) = do
  case ByteString -> Either (Pos, String) [Doc (Node Pos)]
decodeNode (ByteString -> ByteString
BS.fromStrict ByteString
bs) of
    Left (Pos, String)
e -> Text -> IO (Tag "yaml" Lexemes)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text
"cannot decode the YAML document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Pos, String) -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Pos, String)
e :: Text)
    Right [Doc (Node Pos)]
docs -> do
      let yamlOptions :: [(YamlName, [Text])]
yamlOptions = Node Pos -> [(YamlName, [Text])]
collectYamlOptions (Node Pos -> [(YamlName, [Text])])
-> (Doc (Node Pos) -> Node Pos)
-> Doc (Node Pos)
-> [(YamlName, [Text])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (Node Pos) -> Node Pos
forall n. Doc n -> n
docRoot (Doc (Node Pos) -> [(YamlName, [Text])])
-> [Doc (Node Pos)] -> [(YamlName, [Text])]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Doc (Node Pos)]
docs
      let yos :: [(YamlName, [Text])]
yos = case OptionNames
optionNames of
            OptionNames [] -> [(YamlName, [Text])]
yamlOptions
            OptionNames [Text]
os -> do
              let osNames :: [YamlName]
osNames = YamlNames -> Text -> YamlName
toYamlName YamlNames
yns (Text -> YamlName) -> [Text] -> [YamlName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
os
              ((YamlName, [Text]) -> Bool)
-> [(YamlName, [Text])] -> [(YamlName, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(YamlName
name, [Text]
_) -> YamlName
name YamlName -> [YamlName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [YamlName]
osNames) [(YamlName, [Text])]
yamlOptions
      Tag "yaml" Lexemes -> IO (Tag "yaml" Lexemes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tag "yaml" Lexemes -> IO (Tag "yaml" Lexemes))
-> ([Lexemes] -> Tag "yaml" Lexemes)
-> [Lexemes]
-> IO (Tag "yaml" Lexemes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexemes -> Tag "yaml" Lexemes
forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (Lexemes -> Tag "yaml" Lexemes)
-> ([Lexemes] -> Lexemes) -> [Lexemes] -> Tag "yaml" Lexemes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexemes] -> Lexemes
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Lexemes] -> IO (Tag "yaml" Lexemes))
-> [Lexemes] -> IO (Tag "yaml" Lexemes)
forall a b. (a -> b) -> a -> b
$ (\(YamlName
name, [Text]
vs) -> Text -> [Text] -> Lexemes
optionsLexemes (YamlNames -> YamlName -> Text
fromYamlName YamlNames
yns YamlName
name) [Text]
vs) ((YamlName, [Text]) -> Lexemes)
-> [(YamlName, [Text])] -> [Lexemes]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(YamlName, [Text])]
yos

-- | Text needs to have an Exception instance in order to use throwIO
instance Exception Text

-- | Path for a YAML document
newtype YamlPath = YamlPath {YamlPath -> Text
yamlPath :: Text} deriving (YamlPath -> YamlPath -> Bool
(YamlPath -> YamlPath -> Bool)
-> (YamlPath -> YamlPath -> Bool) -> Eq YamlPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YamlPath -> YamlPath -> Bool
$c/= :: YamlPath -> YamlPath -> Bool
== :: YamlPath -> YamlPath -> Bool
$c== :: YamlPath -> YamlPath -> Bool
Eq, Int -> YamlPath -> ShowS
[YamlPath] -> ShowS
YamlPath -> String
(Int -> YamlPath -> ShowS)
-> (YamlPath -> String) -> ([YamlPath] -> ShowS) -> Show YamlPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YamlPath] -> ShowS
$cshowList :: [YamlPath] -> ShowS
show :: YamlPath -> String
$cshow :: YamlPath -> String
showsPrec :: Int -> YamlPath -> ShowS
$cshowsPrec :: Int -> YamlPath -> ShowS
Show, NonEmpty YamlPath -> YamlPath
YamlPath -> YamlPath -> YamlPath
(YamlPath -> YamlPath -> YamlPath)
-> (NonEmpty YamlPath -> YamlPath)
-> (forall b. Integral b => b -> YamlPath -> YamlPath)
-> Semigroup YamlPath
forall b. Integral b => b -> YamlPath -> YamlPath
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> YamlPath -> YamlPath
$cstimes :: forall b. Integral b => b -> YamlPath -> YamlPath
sconcat :: NonEmpty YamlPath -> YamlPath
$csconcat :: NonEmpty YamlPath -> YamlPath
<> :: YamlPath -> YamlPath -> YamlPath
$c<> :: YamlPath -> YamlPath -> YamlPath
Semigroup, Semigroup YamlPath
YamlPath
Semigroup YamlPath
-> YamlPath
-> (YamlPath -> YamlPath -> YamlPath)
-> ([YamlPath] -> YamlPath)
-> Monoid YamlPath
[YamlPath] -> YamlPath
YamlPath -> YamlPath -> YamlPath
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [YamlPath] -> YamlPath
$cmconcat :: [YamlPath] -> YamlPath
mappend :: YamlPath -> YamlPath -> YamlPath
$cmappend :: YamlPath -> YamlPath -> YamlPath
mempty :: YamlPath
$cmempty :: YamlPath
Monoid)

-- | ByteString representing a YAML document
newtype YamlByteString = YamlByteString {YamlByteString -> ByteString
yamlByteString :: ByteString} deriving (YamlByteString -> YamlByteString -> Bool
(YamlByteString -> YamlByteString -> Bool)
-> (YamlByteString -> YamlByteString -> Bool) -> Eq YamlByteString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YamlByteString -> YamlByteString -> Bool
$c/= :: YamlByteString -> YamlByteString -> Bool
== :: YamlByteString -> YamlByteString -> Bool
$c== :: YamlByteString -> YamlByteString -> Bool
Eq, Int -> YamlByteString -> ShowS
[YamlByteString] -> ShowS
YamlByteString -> String
(Int -> YamlByteString -> ShowS)
-> (YamlByteString -> String)
-> ([YamlByteString] -> ShowS)
-> Show YamlByteString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YamlByteString] -> ShowS
$cshowList :: [YamlByteString] -> ShowS
show :: YamlByteString -> String
$cshow :: YamlByteString -> String
showsPrec :: Int -> YamlByteString -> ShowS
$cshowsPrec :: Int -> YamlByteString -> ShowS
Show, NonEmpty YamlByteString -> YamlByteString
YamlByteString -> YamlByteString -> YamlByteString
(YamlByteString -> YamlByteString -> YamlByteString)
-> (NonEmpty YamlByteString -> YamlByteString)
-> (forall b. Integral b => b -> YamlByteString -> YamlByteString)
-> Semigroup YamlByteString
forall b. Integral b => b -> YamlByteString -> YamlByteString
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> YamlByteString -> YamlByteString
$cstimes :: forall b. Integral b => b -> YamlByteString -> YamlByteString
sconcat :: NonEmpty YamlByteString -> YamlByteString
$csconcat :: NonEmpty YamlByteString -> YamlByteString
<> :: YamlByteString -> YamlByteString -> YamlByteString
$c<> :: YamlByteString -> YamlByteString -> YamlByteString
Semigroup, Semigroup YamlByteString
YamlByteString
Semigroup YamlByteString
-> YamlByteString
-> (YamlByteString -> YamlByteString -> YamlByteString)
-> ([YamlByteString] -> YamlByteString)
-> Monoid YamlByteString
[YamlByteString] -> YamlByteString
YamlByteString -> YamlByteString -> YamlByteString
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [YamlByteString] -> YamlByteString
$cmconcat :: [YamlByteString] -> YamlByteString
mappend :: YamlByteString -> YamlByteString -> YamlByteString
$cmappend :: YamlByteString -> YamlByteString -> YamlByteString
mempty :: YamlByteString
$cmempty :: YamlByteString
Monoid)

-- | Default path for a configuration file
--   By default we don't read from a configuration file
defaultYamlPath :: Maybe YamlPath
defaultYamlPath :: Maybe YamlPath
defaultYamlPath = Maybe YamlPath
forall a. Maybe a
Nothing

-- | Read yaml as a ByteString from a configuration file
readYamlFile :: Maybe YamlPath -> IO (Maybe YamlByteString)
readYamlFile :: Maybe YamlPath -> IO (Maybe YamlByteString)
readYamlFile Maybe YamlPath
Nothing = Maybe YamlByteString -> IO (Maybe YamlByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe YamlByteString
forall a. Maybe a
Nothing
readYamlFile (Just (YamlPath Text
path)) = YamlByteString -> Maybe YamlByteString
forall a. a -> Maybe a
Just (YamlByteString -> Maybe YamlByteString)
-> (ByteString -> YamlByteString)
-> ByteString
-> Maybe YamlByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> YamlByteString
YamlByteString (ByteString -> Maybe YamlByteString)
-> IO ByteString -> IO (Maybe YamlByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
path)

-- | Collect what looks like options in a YAML document i.e. any list of strings leading to a scalar
collectYamlOptions :: Node Pos -> [(YamlName, [Text])]
collectYamlOptions :: Node Pos -> [(YamlName, [Text])]
collectYamlOptions (Scalar Pos
_ (SStr Text
t)) = [([Text] -> YamlName
YamlName [], [Text
t])]
collectYamlOptions (Scalar Pos
_ (SBool Bool
b)) = [([Text] -> YamlName
YamlName [], [Bool -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Bool
b])]
collectYamlOptions (Scalar Pos
_ (SInt Integer
i)) = [([Text] -> YamlName
YamlName [], [Integer -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Integer
i])]
collectYamlOptions (Scalar Pos
_ Scalar
_) = []
collectYamlOptions (Mapping Pos
_ Tag
_ Mapping Pos
m) =
  [[(YamlName, [Text])]] -> [(YamlName, [Text])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(YamlName, [Text])]] -> [(YamlName, [Text])])
-> [[(YamlName, [Text])]] -> [(YamlName, [Text])]
forall a b. (a -> b) -> a -> b
$ (Node Pos -> Node Pos -> [(YamlName, [Text])])
-> (Node Pos, Node Pos) -> [(YamlName, [Text])]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Node Pos -> Node Pos -> [(YamlName, [Text])]
toKeysValue ((Node Pos, Node Pos) -> [(YamlName, [Text])])
-> [(Node Pos, Node Pos)] -> [[(YamlName, [Text])]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mapping Pos -> [(Node Pos, Node Pos)]
forall k a. Map k a -> [(k, a)]
M.assocs Mapping Pos
m
  where
    toKeysValue :: Node Pos -> Node Pos -> [(YamlName, [Text])]
    toKeysValue :: Node Pos -> Node Pos -> [(YamlName, [Text])]
toKeysValue (Scalar Pos
_ (SStr Text
k)) Node Pos
n =
      (\(YamlName [Text]
ks, [Text]
vs) -> ([Text] -> YamlName
YamlName (Text
k Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ks), [Text]
vs)) ((YamlName, [Text]) -> (YamlName, [Text]))
-> [(YamlName, [Text])] -> [(YamlName, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node Pos -> [(YamlName, [Text])]
collectYamlOptions Node Pos
n
    toKeysValue Node Pos
_ Node Pos
_ = []
collectYamlOptions (Sequence Pos
_ Tag
_ [Node Pos]
ns) = [[(YamlName, [Text])]] -> [(YamlName, [Text])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(YamlName, [Text])]] -> [(YamlName, [Text])])
-> [[(YamlName, [Text])]] -> [(YamlName, [Text])]
forall a b. (a -> b) -> a -> b
$ Node Pos -> [(YamlName, [Text])]
collectYamlOptions (Node Pos -> [(YamlName, [Text])])
-> [Node Pos] -> [[(YamlName, [Text])]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node Pos]
ns
collectYamlOptions (Anchor Pos
_ NodeId
_ Node Pos
n) = Node Pos -> [(YamlName, [Text])]
collectYamlOptions Node Pos
n

-- | A YAML name is represented by a list of keys
newtype YamlName = YamlName {YamlName -> [Text]
yamlName :: [Text]} deriving (YamlName -> YamlName -> Bool
(YamlName -> YamlName -> Bool)
-> (YamlName -> YamlName -> Bool) -> Eq YamlName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YamlName -> YamlName -> Bool
$c/= :: YamlName -> YamlName -> Bool
== :: YamlName -> YamlName -> Bool
$c== :: YamlName -> YamlName -> Bool
Eq, Int -> YamlName -> ShowS
[YamlName] -> ShowS
YamlName -> String
(Int -> YamlName -> ShowS)
-> (YamlName -> String) -> ([YamlName] -> ShowS) -> Show YamlName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YamlName] -> ShowS
$cshowList :: [YamlName] -> ShowS
show :: YamlName -> String
$cshow :: YamlName -> String
showsPrec :: Int -> YamlName -> ShowS
$cshowsPrec :: Int -> YamlName -> ShowS
Show)

-- | Configuration for transforming a YAML name into an option name
--   and for transforming an option name into a YAML name
--   We consider that a YAML name is a sequence of string keys in a nested YAML document
data YamlNames = YamlNames
  { YamlNames -> YamlName -> Text
fromYamlName :: YamlName -> Text,
    YamlNames -> Text -> YamlName
toYamlName :: Text -> YamlName
  }

-- | Default conversion functions for YAML variables names to option names
--   We only keep in names on the leaves of the YAML tree
--
--  @fromYamlName ["section", "option_name"] == "option-name"@
--  @toYamlName "option-name" == ["option_name"]@
defaultYamlNames :: YamlNames
defaultYamlNames :: YamlNames
defaultYamlNames =
  YamlNames
    { fromYamlName :: YamlName -> Text
fromYamlName = \(YamlName [Text]
ts) ->
        case [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ts of
          [] -> Text
""
          Text
t : [Text]
_ -> Text -> Text
underscoreToHyphenated Text
t,
      toYamlName :: Text -> YamlName
toYamlName = [Text] -> YamlName
YamlName ([Text] -> YamlName) -> (Text -> [Text]) -> Text -> YamlName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphenatedToUnderscore
    }

-- * Sources and priorities

-- | List of sources sorted by the highest priority to the lowest
newtype Priorities = Priorities [Source] deriving (Priorities -> Priorities -> Bool
(Priorities -> Priorities -> Bool)
-> (Priorities -> Priorities -> Bool) -> Eq Priorities
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Priorities -> Priorities -> Bool
$c/= :: Priorities -> Priorities -> Bool
== :: Priorities -> Priorities -> Bool
$c== :: Priorities -> Priorities -> Bool
Eq, Int -> Priorities -> ShowS
[Priorities] -> ShowS
Priorities -> String
(Int -> Priorities -> ShowS)
-> (Priorities -> String)
-> ([Priorities] -> ShowS)
-> Show Priorities
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Priorities] -> ShowS
$cshowList :: [Priorities] -> ShowS
show :: Priorities -> String
$cshow :: Priorities -> String
showsPrec :: Int -> Priorities -> ShowS
$cshowsPrec :: Int -> Priorities -> ShowS
Show)

-- | By default we take environment values, then command line values, then values coming from a configuration file
defaultPriorities :: Priorities
defaultPriorities :: Priorities
defaultPriorities = [Source] -> Priorities
Priorities [Source
environmentSource, Source
commandLineSource, Source
yamlSource]

-- | Sort a list of values associated with a source, using Priorities to determine the order
sortBySource :: Priorities -> [(Source, a)] -> [a]
sortBySource :: forall a. Priorities -> [(Source, a)] -> [a]
sortBySource (Priorities [Source]
ps) [(Source, a)]
ss = do
  let compareSource :: Source -> Source -> Ordering
compareSource Source
source1 Source
source2 = Maybe Int -> Maybe Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Source -> [Source] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Source
source1 [Source]
ps) (Source -> [Source] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Source
source2 [Source]
ps)
  (Source, a) -> a
forall a b. (a, b) -> b
snd ((Source, a) -> a) -> [(Source, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Source, a) -> (Source, a) -> Ordering)
-> [(Source, a)] -> [(Source, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Source
s1, a
_) (Source
s2, a
_) -> Source -> Source -> Ordering
compareSource Source
s1 Source
s2) [(Source, a)]
ss

-- | Source of an option value
--   This is modelled as a simple newtype on Text in order to enable
--   the creation of new sources
newtype Source = Source Text deriving (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
(Int -> Source -> ShowS)
-> (Source -> String) -> ([Source] -> ShowS) -> Show Source
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> String
$cshow :: Source -> String
showsPrec :: Int -> Source -> ShowS
$cshowsPrec :: Int -> Source -> ShowS
Show)

-- | Source of options values coming from the environment
environmentSource :: Source
environmentSource :: Source
environmentSource = Text -> Source
Source Text
"environment"

-- | Source of options values coming from the command line
commandLineSource :: Source
commandLineSource :: Source
commandLineSource = Text -> Source
Source Text
"commandline"

-- | Source of options values coming from a YAML configuration file
yamlSource :: Source
yamlSource :: Source
yamlSource = Text -> Source
Source Text
"yaml"