{-# 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 = 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 (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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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) 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> YamlPath
YamlPath Text
path) 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 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 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) 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) 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
    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
    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
    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
    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
    forall a b c. AddRegistryLike a b c => a -> b -> c
<: forall a. Typeable a => a -> Typed a
fun IO Arguments
getCommandlineArguments
    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
    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
    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
    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 (forall a. Monoid a => a
mempty :: OptionNames)
    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
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
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
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
[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, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "environment" Lexemes
env), (Source
yamlSource, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "yaml" Lexemes
yaml), (Source
commandLineSource, forall (s :: Symbol) a. Tag s a -> a
unTag Tag "commandline" Lexemes
cl)]
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Lexemes -> Lexemes -> Lexemes
override forall a. Monoid a => a
mempty (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ 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 = forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Lexemes
lexArgs 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. ConvertText a b => a -> b
toS 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
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
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
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
[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 <- 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 forall a b. (a -> b) -> a -> b
$ forall a b. ConvertText a b => a -> b
toS String
n) (forall a b. ConvertText a b => a -> b
toS String
v)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Lexemes]
lexemes
getValuesFromEnvironment (OptionNames [Text]
os) EnvironmentNames
ens = do
  [Lexemes]
lexemes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Text]
os forall a b. (a -> b) -> a -> b
$ \Text
o -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Text -> Text -> Lexemes
optionLexemes Text
o forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ EnvironmentNames -> Text -> Text
toEnvironmentName EnvironmentNames
ens Text
o)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower,
      toEnvironmentName :: Text -> Text
toEnvironmentName = Text -> Text
T.toUpper 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag (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 -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text
"cannot decode the YAML document: " forall a. Semigroup a => a -> a -> a
<> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Doc n -> n
docRoot 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
os
              forall a. (a -> Bool) -> [a] -> [a]
filter (\(YamlName
name, [Text]
_) -> YamlName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [YamlName]
osNames) [(YamlName, [Text])]
yamlOptions
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) fun.
CNumArgs (CountArgs fun) fun =>
fun -> Apply (Tag s) (CountArgs fun) fun
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold 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) 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
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
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
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
[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
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
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
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
[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 = 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
readYamlFile (Just (YamlPath Text
path)) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> YamlByteString
YamlByteString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile (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 [], [forall a b. (Show a, StringConv String b) => a -> b
show Bool
b])]
collectYamlOptions (Scalar Pos
_ (SInt Integer
i)) = [([Text] -> YamlName
YamlName [], [forall a b. (Show a, StringConv String b) => a -> b
show Integer
i])]
collectYamlOptions (Scalar Pos
_ Scalar
_) = []
collectYamlOptions (Mapping Pos
_ Tag
_ Mapping Pos
m) =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Node Pos -> Node Pos -> [(YamlName, [Text])]
toKeysValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. a -> [a] -> [a]
: [Text]
ks), [Text]
vs)) 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) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ Node Pos -> [(YamlName, [Text])]
collectYamlOptions 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
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
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 forall a. [a] -> [a]
reverse [Text]
ts of
          [] -> Text
""
          Text
t : [Text]
_ -> Text -> Text
underscoreToHyphenated Text
t,
      toYamlName :: Text -> YamlName
toYamlName = [Text] -> YamlName
YamlName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
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
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 = forall a. Ord a => a -> a -> Ordering
compare (forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Source
source1 [Source]
ps) (forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Source
source2 [Source]
ps)
  forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
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
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"