{-# Language MultiWayIf, OverloadedStrings, RankNTypes #-}
-- | This module deals with loading configurations.
module Crux.Config
  ( -- * Writing configurations
    Config(..), cfgJoin

    -- ** Configuration files
  , SectionsSpec, section, sectionMaybe
  , yesOrNoSpec, stringSpec, numSpec, fractionalSpec
  , oneOrList, fileSpec, dirSpec, listSpec

    -- ** Environment variables
  , EnvDescr(..), mapEnvDescr, liftEnvDescr, liftOptDescr

    -- ** Command line options
  , OptDescr(..), ArgDescr(..), OptSetter
  , mapOptDescr, mapArgDescr
  , parsePosNum
  ) where

import Control.Lens (Lens', set, view)
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import Text.Read(readMaybe)

import SimpleGetOpt
import Config.Schema


{- | Loading options from multiple sources.  First we load configuration
from a file, then we consider environment variables, and finally we
update using the command line flags. If there is no configuration file
provided, then this is equivalent to having an empty configuration file,
so the config file schema should be able to cope with missing settings. -}

data Config opts = Config
  { forall opts. Config opts -> SectionsSpec opts
cfgFile     :: SectionsSpec opts
    -- ^ Configuration file settings (and, implicitly, defaults).

  , forall opts. Config opts -> [EnvDescr opts]
cfgEnv      :: [ EnvDescr opts ]
    -- ^ Settings from environment variables

  , forall opts. Config opts -> [OptDescr opts]
cfgCmdLineFlag  :: [ OptDescr opts ]
    -- ^ Command line flags.
  }

-- | How the value of an environment variable contributes to the options.
data EnvDescr opts =
  EnvVar { forall opts. EnvDescr opts -> String
evName  :: String                   -- ^ Name of variable
         , forall opts. EnvDescr opts -> String
evDoc   :: String                   -- ^ Documentation
         , forall opts. EnvDescr opts -> String -> OptSetter opts
evValue :: String -> OptSetter opts -- ^ How it affects the options
         }

-- | Lifts an 'EnvDescr' for some smaller type 'b' into an 'EnvDescr' with the
-- same name and documentation, but operating over a larger type 'a'.  Useful
-- for embedding the options of another executable within an executable with
-- possibly additional options.
liftEnvDescr :: Lens' a b -> EnvDescr b -> EnvDescr a
liftEnvDescr :: forall a b. Lens' a b -> EnvDescr b -> EnvDescr a
liftEnvDescr Lens' a b
lens EnvDescr b
envDescr =
  EnvDescr b
envDescr { evValue = liftOptSetter lens . evValue envDescr }

-- | Lifts an 'OptDescr' for some smaller type 'b' into an 'OptDescr' with the
-- same name and documentation, but operating over a larger type 'a'.  Useful
-- for embedding the options of another executable within an executable with
-- possibly additional options.
liftOptDescr :: Lens' a b -> OptDescr b -> OptDescr a
liftOptDescr :: forall a b. Lens' a b -> OptDescr b -> OptDescr a
liftOptDescr Lens' a b
lens (Option String
a [String]
b String
c ArgDescr b
d) = String -> [String] -> String -> ArgDescr a -> OptDescr a
forall a. String -> [String] -> String -> ArgDescr a -> OptDescr a
Option String
a [String]
b String
c (Lens' a b -> ArgDescr b -> ArgDescr a
forall a b. Lens' a b -> ArgDescr b -> ArgDescr a
liftArgDescr (b -> f b) -> a -> f a
Lens' a b
lens ArgDescr b
d)

liftArgDescr :: Lens' a b -> ArgDescr b -> ArgDescr a
liftArgDescr :: forall a b. Lens' a b -> ArgDescr b -> ArgDescr a
liftArgDescr Lens' a b
lens (NoArg OptSetter b
s) = OptSetter a -> ArgDescr a
forall a. OptSetter a -> ArgDescr a
NoArg (Lens' a b -> OptSetter b -> OptSetter a
forall a b. Lens' a b -> OptSetter b -> OptSetter a
liftOptSetter (b -> f b) -> a -> f a
Lens' a b
lens OptSetter b
s)
liftArgDescr Lens' a b
lens (ReqArg String
v String -> OptSetter b
s) = String -> (String -> OptSetter a) -> ArgDescr a
forall a. String -> (String -> OptSetter a) -> ArgDescr a
ReqArg String
v (Lens' a b -> OptSetter b -> OptSetter a
forall a b. Lens' a b -> OptSetter b -> OptSetter a
liftOptSetter (b -> f b) -> a -> f a
Lens' a b
lens (OptSetter b -> OptSetter a)
-> (String -> OptSetter b) -> String -> OptSetter a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OptSetter b
s)
liftArgDescr Lens' a b
lens (OptArg String
v Maybe String -> OptSetter b
s) = String -> (Maybe String -> OptSetter a) -> ArgDescr a
forall a. String -> (Maybe String -> OptSetter a) -> ArgDescr a
OptArg String
v (Lens' a b -> OptSetter b -> OptSetter a
forall a b. Lens' a b -> OptSetter b -> OptSetter a
liftOptSetter (b -> f b) -> a -> f a
Lens' a b
lens (OptSetter b -> OptSetter a)
-> (Maybe String -> OptSetter b) -> Maybe String -> OptSetter a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> OptSetter b
s)

liftOptSetter :: Lens' a b -> OptSetter b -> OptSetter a
liftOptSetter :: forall a b. Lens' a b -> OptSetter b -> OptSetter a
liftOptSetter Lens' a b
lens OptSetter b
v a
o = (b -> a -> a) -> a -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ASetter a a b b -> b -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter a a b b
Lens' a b
lens) a
o (b -> a) -> Either String b -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptSetter b
v (Getting b a b -> a -> b
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting b a b
Lens' a b
lens a
o)


cfgJoin :: Config a -> Config b -> Config (a,b)
cfgJoin :: forall a b. Config a -> Config b -> Config (a, b)
cfgJoin Config a
cfg1 Config b
cfg2 = Config
  { cfgFile :: SectionsSpec (a, b)
cfgFile         = (,) (a -> b -> (a, b)) -> SectionsSpec a -> SectionsSpec (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config a -> SectionsSpec a
forall opts. Config opts -> SectionsSpec opts
cfgFile Config a
cfg1 SectionsSpec (b -> (a, b)) -> SectionsSpec b -> SectionsSpec (a, b)
forall a b.
SectionsSpec (a -> b) -> SectionsSpec a -> SectionsSpec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Config b -> SectionsSpec b
forall opts. Config opts -> SectionsSpec opts
cfgFile Config b
cfg2
  , cfgEnv :: [EnvDescr (a, b)]
cfgEnv          = (EnvDescr a -> EnvDescr (a, b))
-> [EnvDescr a] -> [EnvDescr (a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((OptSetter a -> OptSetter (a, b)) -> EnvDescr a -> EnvDescr (a, b)
forall a b.
(OptSetter a -> OptSetter b) -> EnvDescr a -> EnvDescr b
mapEnvDescr OptSetter a -> OptSetter (a, b)
forall a b. OptSetter a -> OptSetter (a, b)
inFst) (Config a -> [EnvDescr a]
forall opts. Config opts -> [EnvDescr opts]
cfgEnv Config a
cfg1) [EnvDescr (a, b)] -> [EnvDescr (a, b)] -> [EnvDescr (a, b)]
forall a. [a] -> [a] -> [a]
++
                      (EnvDescr b -> EnvDescr (a, b))
-> [EnvDescr b] -> [EnvDescr (a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((OptSetter b -> OptSetter (a, b)) -> EnvDescr b -> EnvDescr (a, b)
forall a b.
(OptSetter a -> OptSetter b) -> EnvDescr a -> EnvDescr b
mapEnvDescr OptSetter b -> OptSetter (a, b)
forall b a. OptSetter b -> OptSetter (a, b)
inSnd) (Config b -> [EnvDescr b]
forall opts. Config opts -> [EnvDescr opts]
cfgEnv Config b
cfg2)
  , cfgCmdLineFlag :: [OptDescr (a, b)]
cfgCmdLineFlag  = (OptDescr a -> OptDescr (a, b))
-> [OptDescr a] -> [OptDescr (a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((OptSetter a -> OptSetter (a, b)) -> OptDescr a -> OptDescr (a, b)
forall a b.
(OptSetter a -> OptSetter b) -> OptDescr a -> OptDescr b
mapOptDescr OptSetter a -> OptSetter (a, b)
forall a b. OptSetter a -> OptSetter (a, b)
inFst) (Config a -> [OptDescr a]
forall opts. Config opts -> [OptDescr opts]
cfgCmdLineFlag Config a
cfg1) [OptDescr (a, b)] -> [OptDescr (a, b)] -> [OptDescr (a, b)]
forall a. [a] -> [a] -> [a]
++
                      (OptDescr b -> OptDescr (a, b))
-> [OptDescr b] -> [OptDescr (a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((OptSetter b -> OptSetter (a, b)) -> OptDescr b -> OptDescr (a, b)
forall a b.
(OptSetter a -> OptSetter b) -> OptDescr a -> OptDescr b
mapOptDescr OptSetter b -> OptSetter (a, b)
forall b a. OptSetter b -> OptSetter (a, b)
inSnd) (Config b -> [OptDescr b]
forall opts. Config opts -> [OptDescr opts]
cfgCmdLineFlag Config b
cfg2)
  }

inFst :: OptSetter a -> OptSetter (a,b)
inFst :: forall a b. OptSetter a -> OptSetter (a, b)
inFst OptSetter a
f = \(a
a,b
b) -> do a
a' <- OptSetter a
f a
a
                       (a, b) -> Either String (a, b)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a',b
b)

inSnd :: OptSetter b -> OptSetter (a,b)
inSnd :: forall b a. OptSetter b -> OptSetter (a, b)
inSnd OptSetter b
f = \(a
a,b
b) -> do b
b' <- OptSetter b
f b
b
                       (a, b) -> Either String (a, b)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a,b
b')

--------------------------------------------------------------------------------


-- | An option that can be configured in the file.
section :: Text        {- ^ Option name -} ->
           ValueSpec a {- ^ What type of value we expect -} ->
           a           {- ^ Default value to use if option not specified -} ->
           Text        {-^ Documentation -} ->
           SectionsSpec a
section :: forall a. Text -> ValueSpec a -> a -> Text -> SectionsSpec a
section Text
nm ValueSpec a
spec a
def Text
doc = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def (Maybe a -> a) -> SectionsSpec (Maybe a) -> SectionsSpec a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection' Text
nm ValueSpec a
spec Text
doc

sectionMaybe :: Text {- ^ Option name -} ->
                ValueSpec a {- ^ What type of value we expect -} ->
                Text        {- ^ Documentation -} ->
                SectionsSpec (Maybe a)
sectionMaybe :: forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
sectionMaybe = Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
forall a. Text -> ValueSpec a -> Text -> SectionsSpec (Maybe a)
optSection'

fileSpec :: ValueSpec FilePath
fileSpec :: ValueSpec String
fileSpec = Text -> ValueSpec String -> ValueSpec String
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"FILE" ValueSpec String
stringSpec

dirSpec :: ValueSpec FilePath
dirSpec :: ValueSpec String
dirSpec = Text -> ValueSpec String -> ValueSpec String
forall a. Text -> ValueSpec a -> ValueSpec a
namedSpec Text
"DIR" ValueSpec String
stringSpec

--------------------------------------------------------------------------------



--------------------------------------------------------------------------------

mapEnvDescr :: (OptSetter a -> OptSetter b) -> EnvDescr a -> EnvDescr b
mapEnvDescr :: forall a b.
(OptSetter a -> OptSetter b) -> EnvDescr a -> EnvDescr b
mapEnvDescr OptSetter a -> OptSetter b
f EnvDescr a
e = EnvDescr a
e { evValue = f . evValue e }

mapArgDescr :: (OptSetter a -> OptSetter b) -> ArgDescr a -> ArgDescr b
mapArgDescr :: forall a b.
(OptSetter a -> OptSetter b) -> ArgDescr a -> ArgDescr b
mapArgDescr OptSetter a -> OptSetter b
g ArgDescr a
ad =
  case ArgDescr a
ad of
    NoArg OptSetter a
os   -> OptSetter b -> ArgDescr b
forall a. OptSetter a -> ArgDescr a
NoArg (OptSetter a -> OptSetter b
g OptSetter a
os)
    ReqArg String
s String -> OptSetter a
f -> String -> (String -> OptSetter b) -> ArgDescr b
forall a. String -> (String -> OptSetter a) -> ArgDescr a
ReqArg String
s (OptSetter a -> OptSetter b
g (OptSetter a -> OptSetter b)
-> (String -> OptSetter a) -> String -> OptSetter b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OptSetter a
f)
    OptArg String
s Maybe String -> OptSetter a
f -> String -> (Maybe String -> OptSetter b) -> ArgDescr b
forall a. String -> (Maybe String -> OptSetter a) -> ArgDescr a
OptArg String
s (OptSetter a -> OptSetter b
g (OptSetter a -> OptSetter b)
-> (Maybe String -> OptSetter a) -> Maybe String -> OptSetter b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> OptSetter a
f)

mapOptDescr :: (OptSetter a -> OptSetter b) -> OptDescr a -> OptDescr b
mapOptDescr :: forall a b.
(OptSetter a -> OptSetter b) -> OptDescr a -> OptDescr b
mapOptDescr OptSetter a -> OptSetter b
f OptDescr a
o = OptDescr a
o { optArgument = mapArgDescr f (optArgument o) }




parsePosNum :: (Read a, Num a, Ord a) =>
  String -> (a -> opts -> opts) -> String -> OptSetter opts
parsePosNum :: forall a opts.
(Read a, Num a, Ord a) =>
String -> (a -> opts -> opts) -> String -> OptSetter opts
parsePosNum String
thing a -> opts -> opts
mk = \String
txt opts
opts ->
  case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
txt of
    Just a
a | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 -> opts -> Either String opts
forall a b. b -> Either a b
Right (a -> opts -> opts
mk a
a opts
opts)
    Maybe a
_ -> String -> Either String opts
forall a b. a -> Either a b
Left (String
"Invalid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
thing)