{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module What4.Config
(
ConfigOption
, configOption
, configOptionType
, configOptionName
, configOptionText
, configOptionNameParts
, OptionSetting(..)
, Opt(..)
, setUnicodeOpt
, setIntegerOpt
, setBoolOpt
, OptionStyle(..)
, set_opt_default
, set_opt_onset
, OptionSetResult(..)
, optOK
, optWarn
, optErr
, checkOptSetResult
, OptSetFailure(..)
, OptGetFailure(..)
, OptCreateFailure(..)
, Bound(..)
, boolOptSty
, integerOptSty
, realOptSty
, stringOptSty
, realWithRangeOptSty
, realWithMinOptSty
, realWithMaxOptSty
, integerWithRangeOptSty
, integerWithMinOptSty
, integerWithMaxOptSty
, enumOptSty
, listOptSty
, executablePathOptSty
, ConfigDesc
, mkOpt
, opt
, optV
, optU
, optUV
, copyOpt
, deprecatedOpt
, Config
, initialConfig
, extendConfig
, tryExtendConfig
, splitConfig
, getOptionSetting
, getOptionSettingFromText
, ConfigValue(..)
, getConfigValues
, configHelp
, verbosity
, verbosityLogger
) where
import Control.Applicative ( Const(..), (<|>) )
import Control.Concurrent.MVar
import qualified Control.Concurrent.ReadWriteVar as RWV
import Control.Lens ((&))
import qualified Control.Lens.Combinators as LC
import Control.Monad (foldM, when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Writer.Strict (MonadWriter(..), WriterT, execWriterT)
import Data.Foldable (toList)
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Parameterized.Classes
import Data.Parameterized.Some
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void
import System.IO ( Handle, hPutStr )
import System.IO.Error ( ioeGetErrorString )
import Prettyprinter hiding (Unbounded)
import What4.BaseTypes
import What4.Concrete
import qualified What4.Utils.Environment as Env
import What4.Utils.StringLiteral
data ConfigOption (tp :: BaseType) where
ConfigOption :: BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
instance Show (ConfigOption tp) where
show :: ConfigOption tp -> String
show = forall (tp :: BaseType). ConfigOption tp -> String
configOptionName
configOption :: BaseTypeRepr tp -> String -> ConfigOption tp
configOption :: forall (tp :: BaseType).
BaseTypeRepr tp -> String -> ConfigOption tp
configOption BaseTypeRepr tp
tp String
nm =
case Text -> Maybe (NonEmpty Text)
splitPath (String -> Text
Text.pack String
nm) of
Just NonEmpty Text
ps -> forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption BaseTypeRepr tp
tp NonEmpty Text
ps
Maybe (NonEmpty Text)
Nothing -> forall a. HasCallStack => String -> a
error String
"config options cannot have an empty name"
splitPath :: Text -> Maybe (NonEmpty Text)
splitPath :: Text -> Maybe (NonEmpty Text)
splitPath Text
nm =
let nms :: [Text]
nms = Text -> Text -> [Text]
Text.splitOn Text
"." Text
nm in
case [Text]
nms of
(Text
x:[Text]
xs) | forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) (Text
xforall a. a -> [a] -> [a]
:[Text]
xs) -> forall a. a -> Maybe a
Just (Text
xforall a. a -> [a] -> NonEmpty a
:|[Text]
xs)
[Text]
_ -> forall a. Maybe a
Nothing
configOptionNameParts :: ConfigOption tp -> [Text]
configOptionNameParts :: forall (tp :: BaseType). ConfigOption tp -> [Text]
configOptionNameParts (ConfigOption BaseTypeRepr tp
_ (Text
x:|[Text]
xs)) = Text
xforall a. a -> [a] -> [a]
:[Text]
xs
configOptionName :: ConfigOption tp -> String
configOptionName :: forall (tp :: BaseType). ConfigOption tp -> String
configOptionName = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tp :: BaseType). ConfigOption tp -> Text
configOptionText
configOptionText :: ConfigOption tp -> Text
configOptionText :: forall (tp :: BaseType). ConfigOption tp -> Text
configOptionText (ConfigOption BaseTypeRepr tp
_ (Text
x:|[Text]
xs)) = Text -> [Text] -> Text
Text.intercalate Text
"." forall a b. (a -> b) -> a -> b
$ (Text
xforall a. a -> [a] -> [a]
:[Text]
xs)
configOptionType :: ConfigOption tp -> BaseTypeRepr tp
configOptionType :: forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType (ConfigOption BaseTypeRepr tp
tp NonEmpty Text
_) = BaseTypeRepr tp
tp
data OptionSetResult =
OptionSetResult
{ OptionSetResult -> Maybe (Doc Void)
optionSetError :: !(Maybe (Doc Void))
, OptionSetResult -> Seq (Doc Void)
optionSetWarnings :: !(Seq (Doc Void))
}
instance Semigroup OptionSetResult where
OptionSetResult
x <> :: OptionSetResult -> OptionSetResult -> OptionSetResult
<> OptionSetResult
y = OptionSetResult
{ optionSetError :: Maybe (Doc Void)
optionSetError = OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
x forall a. Semigroup a => a -> a -> a
<> OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
y
, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = OptionSetResult -> Seq (Doc Void)
optionSetWarnings OptionSetResult
x forall a. Semigroup a => a -> a -> a
<> OptionSetResult -> Seq (Doc Void)
optionSetWarnings OptionSetResult
y
}
instance Monoid OptionSetResult where
mappend :: OptionSetResult -> OptionSetResult -> OptionSetResult
mappend = forall a. Semigroup a => a -> a -> a
(<>)
mempty :: OptionSetResult
mempty = OptionSetResult
optOK
optOK :: OptionSetResult
optOK :: OptionSetResult
optOK = OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = forall a. Maybe a
Nothing, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = forall a. Monoid a => a
mempty }
optErr :: Doc Void -> OptionSetResult
optErr :: Doc Void -> OptionSetResult
optErr Doc Void
x = OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = forall a. a -> Maybe a
Just Doc Void
x, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = forall a. Monoid a => a
mempty }
optWarn :: Doc Void -> OptionSetResult
optWarn :: Doc Void -> OptionSetResult
optWarn Doc Void
x = OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = forall a. Maybe a
Nothing, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = forall a. a -> Seq a
Seq.singleton Doc Void
x }
data OptionSetting (tp :: BaseType) =
OptionSetting
{ forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName :: ConfigOption tp
, forall (tp :: BaseType).
OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption :: IO (Maybe (ConcreteVal tp))
, forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption :: ConcreteVal tp -> IO OptionSetResult
}
instance Show (OptionSetting tp) where
show :: OptionSetting tp -> String
show = (forall a. Semigroup a => a -> a -> a
<> String
" option setting") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall s a. Cons s s a a => a -> s -> s
LC.cons Char
'\'' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. Snoc s s a a => s -> a -> s
LC.snoc Char
'\'' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName
instance ShowF OptionSetting
data OptionStyle (tp :: BaseType) =
OptionStyle
{ forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type :: BaseTypeRepr tp
, forall (tp :: BaseType).
OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
, forall (tp :: BaseType). OptionStyle tp -> Doc Void
opt_help :: Doc Void
, forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value :: Maybe (ConcreteVal tp)
}
defaultOpt :: BaseTypeRepr tp -> OptionStyle tp
defaultOpt :: forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt BaseTypeRepr tp
tp =
OptionStyle
{ opt_type :: BaseTypeRepr tp
opt_type = BaseTypeRepr tp
tp
, opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset = \Maybe (ConcreteVal tp)
_ ConcreteVal tp
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
, opt_help :: Doc Void
opt_help = forall a. Monoid a => a
mempty
, opt_default_value :: Maybe (ConcreteVal tp)
opt_default_value = forall a. Maybe a
Nothing
}
set_opt_onset :: (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp
-> OptionStyle tp
set_opt_onset :: forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
f OptionStyle tp
s = OptionStyle tp
s { opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset = Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
f }
set_opt_help :: Doc Void
-> OptionStyle tp
-> OptionStyle tp
set_opt_help :: forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
v OptionStyle tp
s = OptionStyle tp
s { opt_help :: Doc Void
opt_help = Doc Void
v }
set_opt_default :: ConcreteVal tp
-> OptionStyle tp
-> OptionStyle tp
set_opt_default :: forall (tp :: BaseType).
ConcreteVal tp -> OptionStyle tp -> OptionStyle tp
set_opt_default ConcreteVal tp
v OptionStyle tp
s = OptionStyle tp
s { opt_default_value :: Maybe (ConcreteVal tp)
opt_default_value = forall a. a -> Maybe a
Just ConcreteVal tp
v }
data Bound r = Exclusive r
| Inclusive r
| Unbounded
boolOptSty :: OptionStyle BaseBoolType
boolOptSty :: OptionStyle BaseBoolType
boolOptSty = forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle tp
OptionStyle BaseTypeRepr BaseBoolType
BaseBoolRepr
(\Maybe (ConcreteVal BaseBoolType)
_ ConcreteVal BaseBoolType
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
Doc Void
"Boolean"
forall a. Maybe a
Nothing
realOptSty :: OptionStyle BaseRealType
realOptSty :: OptionStyle BaseRealType
realOptSty = forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle tp
OptionStyle BaseTypeRepr BaseRealType
BaseRealRepr
(\Maybe (ConcreteVal BaseRealType)
_ ConcreteVal BaseRealType
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
Doc Void
"ℝ"
forall a. Maybe a
Nothing
integerOptSty :: OptionStyle BaseIntegerType
integerOptSty :: OptionStyle BaseIntegerType
integerOptSty = forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle tp
OptionStyle BaseTypeRepr BaseIntegerType
BaseIntegerRepr
(\Maybe (ConcreteVal BaseIntegerType)
_ ConcreteVal BaseIntegerType
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
Doc Void
"ℤ"
forall a. Maybe a
Nothing
stringOptSty :: OptionStyle (BaseStringType Unicode)
stringOptSty :: OptionStyle (BaseStringType Unicode)
stringOptSty = forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle tp
OptionStyle (forall (si :: StringInfo).
StringInfoRepr si -> BaseTypeRepr ('BaseStringType si)
BaseStringRepr StringInfoRepr Unicode
UnicodeRepr)
(\Maybe (ConcreteVal (BaseStringType Unicode))
_ ConcreteVal (BaseStringType Unicode)
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
Doc Void
"string"
forall a. Maybe a
Nothing
checkBound :: Ord a => Bound a -> Bound a -> a -> Bool
checkBound :: forall a. Ord a => Bound a -> Bound a -> a -> Bool
checkBound Bound a
lo Bound a
hi a
a = forall {a}. Ord a => Bound a -> a -> Bool
checkLo Bound a
lo a
a Bool -> Bool -> Bool
&& forall {a}. Ord a => a -> Bound a -> Bool
checkHi a
a Bound a
hi
where checkLo :: Bound a -> a -> Bool
checkLo Bound a
Unbounded a
_ = Bool
True
checkLo (Inclusive a
x) a
y = a
x forall a. Ord a => a -> a -> Bool
<= a
y
checkLo (Exclusive a
x) a
y = a
x forall a. Ord a => a -> a -> Bool
< a
y
checkHi :: a -> Bound a -> Bool
checkHi a
_ Bound a
Unbounded = Bool
True
checkHi a
x (Inclusive a
y) = a
x forall a. Ord a => a -> a -> Bool
<= a
y
checkHi a
x (Exclusive a
y) = a
x forall a. Ord a => a -> a -> Bool
< a
y
docInterval :: Show a => Bound a -> Bound a -> Doc ann
docInterval :: forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound a
lo Bound a
hi = forall {a} {ann}. Show a => Bound a -> Doc ann
docLo Bound a
lo forall a. Semigroup a => a -> a -> a
<> Doc ann
", " forall a. Semigroup a => a -> a -> a
<> forall {a} {ann}. Show a => Bound a -> Doc ann
docHi Bound a
hi
where docLo :: Bound a -> Doc ann
docLo Bound a
Unbounded = Doc ann
"(-∞"
docLo (Exclusive a
r) = Doc ann
"(" forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow a
r
docLo (Inclusive a
r) = Doc ann
"[" forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow a
r
docHi :: Bound a -> Doc ann
docHi Bound a
Unbounded = Doc ann
"+∞)"
docHi (Exclusive a
r) = forall a ann. Show a => a -> Doc ann
viaShow a
r forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
docHi (Inclusive a
r) = forall a ann. Show a => a -> Doc ann
viaShow a
r forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty Bound Rational
lo Bound Rational
hi = OptionStyle BaseRealType
realOptSty forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal BaseRealType)
-> ConcreteVal BaseRealType -> IO OptionSetResult
vf
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
where help :: Doc Void
help = Doc Void
"ℝ ∈" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Rational
lo Bound Rational
hi
vf :: Maybe (ConcreteVal BaseRealType) -> ConcreteVal BaseRealType -> IO OptionSetResult
vf :: Maybe (ConcreteVal BaseRealType)
-> ConcreteVal BaseRealType -> IO OptionSetResult
vf Maybe (ConcreteVal BaseRealType)
_ (ConcreteReal Rational
x)
| forall a. Ord a => Bound a -> Bound a -> a -> Bool
checkBound Bound Rational
lo Bound Rational
hi Rational
x = forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
| Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
forall ann. Rational -> Doc ann
prettyRational Rational
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"out of range, expected real value in"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Rational
lo Bound Rational
hi
realWithMinOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMinOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMinOptSty Bound Rational
lo = Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty Bound Rational
lo forall r. Bound r
Unbounded
realWithMaxOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMaxOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMaxOptSty Bound Rational
hi = Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty forall r. Bound r
Unbounded Bound Rational
hi
integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty Bound Integer
lo Bound Integer
hi = OptionStyle BaseIntegerType
integerOptSty forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal BaseIntegerType)
-> ConcreteVal BaseIntegerType -> IO OptionSetResult
vf
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
where help :: Doc Void
help = Doc Void
"ℤ ∈" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Integer
lo Bound Integer
hi
vf :: Maybe (ConcreteVal BaseIntegerType) -> ConcreteVal BaseIntegerType -> IO OptionSetResult
vf :: Maybe (ConcreteVal BaseIntegerType)
-> ConcreteVal BaseIntegerType -> IO OptionSetResult
vf Maybe (ConcreteVal BaseIntegerType)
_ (ConcreteInteger Integer
x)
| forall a. Ord a => Bound a -> Bound a -> a -> Bool
checkBound Bound Integer
lo Bound Integer
hi Integer
x = forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
| Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
forall a ann. Pretty a => a -> Doc ann
pretty Integer
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"out of range, expected integer value in"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Integer
lo Bound Integer
hi
integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMinOptSty Bound Integer
lo = Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty Bound Integer
lo forall r. Bound r
Unbounded
integerWithMaxOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMaxOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMaxOptSty Bound Integer
hi = Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty forall r. Bound r
Unbounded Bound Integer
hi
enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode)
enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode)
enumOptSty Set Text
elts = OptionStyle (BaseStringType Unicode)
stringOptSty forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
where help :: Doc Void
help = forall ann. Doc ann -> Doc ann
group (Doc Void
"one of: " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
dquotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Text
elts))
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode)
-> IO OptionSetResult
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf Maybe (ConcreteVal (BaseStringType Unicode))
_ (ConcreteString (UnicodeLiteral Text
x))
| Text
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
elts = forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
| Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
Doc Void
"invalid setting" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Text
x) forall a. Semigroup a => a -> a -> a
<>
Doc Void
", expected one of these enums:" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
sep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Text
elts)))
listOptSty
:: Map Text (IO OptionSetResult)
-> OptionStyle (BaseStringType Unicode)
listOptSty :: Map Text (IO OptionSetResult)
-> OptionStyle (BaseStringType Unicode)
listOptSty Map Text (IO OptionSetResult)
values = OptionStyle (BaseStringType Unicode)
stringOptSty forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
where help :: Doc Void
help = forall ann. Doc ann -> Doc ann
group (Doc Void
"one of: " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
dquotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Text (IO OptionSetResult)
values))
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode)
-> IO OptionSetResult
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf Maybe (ConcreteVal (BaseStringType Unicode))
_ (ConcreteString (UnicodeLiteral Text
x)) =
forall a. a -> Maybe a -> a
fromMaybe
(forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
Doc Void
"invalid setting" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Text
x) forall a. Semigroup a => a -> a -> a
<>
Doc Void
", expected one from this list:" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Text (IO OptionSetResult)
values)))
(forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
x Map Text (IO OptionSetResult)
values)
deprecatedOpt :: [ConfigDesc] -> ConfigDesc -> ConfigDesc
deprecatedOpt :: [ConfigDesc] -> ConfigDesc -> ConfigDesc
deprecatedOpt [ConfigDesc]
newerOpt (ConfigDesc ConfigOption tp
o OptionStyle tp
sty Maybe (Doc Void)
desc Maybe [ConfigDesc]
oldRepl) =
let
newRepl :: Maybe [ConfigDesc]
newRepl :: Maybe [ConfigDesc]
newRepl = ([ConfigDesc]
newerOpt forall a. Semigroup a => a -> a -> a
<>) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [ConfigDesc]
oldRepl forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just [])
in forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe [ConfigDesc]
-> ConfigDesc
ConfigDesc ConfigOption tp
o OptionStyle tp
sty Maybe (Doc Void)
desc Maybe [ConfigDesc]
newRepl
executablePathOptSty :: OptionStyle (BaseStringType Unicode)
executablePathOptSty :: OptionStyle (BaseStringType Unicode)
executablePathOptSty = OptionStyle (BaseStringType Unicode)
stringOptSty forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
where help :: Doc Void
help = Doc Void
"<path>"
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode)
-> IO OptionSetResult
vf :: Maybe (ConcreteVal (BaseStringType Unicode))
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
vf Maybe (ConcreteVal (BaseStringType Unicode))
_ (ConcreteString (UnicodeLiteral Text
x)) =
do Either IOError String
me <- forall (m :: Type -> Type) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall (m :: Type -> Type).
(MonadIO m, MonadFail m) =>
String -> m String
Env.findExecutable (Text -> String
Text.unpack Text
x))
case Either IOError String
me of
Right{} -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OptionSetResult
optOK
Left IOError
e -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optWarn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ IOError -> String
ioeGetErrorString IOError
e
data ConfigDesc where
ConfigDesc :: ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe [ConfigDesc]
-> ConfigDesc
instance Show ConfigDesc where
show :: ConfigDesc -> String
show (ConfigDesc ConfigOption tp
o OptionStyle tp
_ Maybe (Doc Void)
_ Maybe [ConfigDesc]
_) = forall a. Show a => a -> String
show ConfigOption tp
o
mkOpt :: ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt :: forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o OptionStyle tp
sty Maybe (Doc Void)
h Maybe (ConcreteVal tp)
def = forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe [ConfigDesc]
-> ConfigDesc
ConfigDesc ConfigOption tp
o OptionStyle tp
sty{ opt_default_value :: Maybe (ConcreteVal tp)
opt_default_value = Maybe (ConcreteVal tp)
def } Maybe (Doc Void)
h forall a. Maybe a
Nothing
opt :: Pretty help
=> ConfigOption tp
-> ConcreteVal tp
-> help
-> ConfigDesc
opt :: forall help (tp :: BaseType).
Pretty help =>
ConfigOption tp -> ConcreteVal tp -> help -> ConfigDesc
opt ConfigOption tp
o ConcreteVal tp
a help
help = forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o))
(forall a. a -> Maybe a
Just (forall a ann. Pretty a => a -> Doc ann
pretty help
help))
(forall a. a -> Maybe a
Just ConcreteVal tp
a)
optV :: forall tp help
. Pretty help
=> ConfigOption tp
-> ConcreteVal tp
-> (ConcreteVal tp -> Maybe help)
-> help
-> ConfigDesc
optV :: forall (tp :: BaseType) help.
Pretty help =>
ConfigOption tp
-> ConcreteVal tp
-> (ConcreteVal tp -> Maybe help)
-> help
-> ConfigDesc
optV ConfigOption tp
o ConcreteVal tp
a ConcreteVal tp -> Maybe help
vf help
h = forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset)
(forall a. a -> Maybe a
Just (forall a ann. Pretty a => a -> Doc ann
pretty help
h))
(forall a. a -> Maybe a
Just ConcreteVal tp
a)
where onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset Maybe (ConcreteVal tp)
_ ConcreteVal tp
x = case ConcreteVal tp -> Maybe help
vf ConcreteVal tp
x of
Maybe help
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
Just help
z -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty help
z
optU :: Pretty help
=> ConfigOption tp
-> help
-> ConfigDesc
optU :: forall help (tp :: BaseType).
Pretty help =>
ConfigOption tp -> help -> ConfigDesc
optU ConfigOption tp
o help
h = forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)) (forall a. a -> Maybe a
Just (forall a ann. Pretty a => a -> Doc ann
pretty help
h)) forall a. Maybe a
Nothing
optUV :: forall help tp.
Pretty help =>
ConfigOption tp ->
(ConcreteVal tp -> Maybe help) ->
help ->
ConfigDesc
optUV :: forall help (tp :: BaseType).
Pretty help =>
ConfigOption tp
-> (ConcreteVal tp -> Maybe help) -> help -> ConfigDesc
optUV ConfigOption tp
o ConcreteVal tp -> Maybe help
vf help
h = forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)
forall a b. a -> (a -> b) -> b
& forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset)
(forall a. a -> Maybe a
Just (forall a ann. Pretty a => a -> Doc ann
pretty help
h))
forall a. Maybe a
Nothing
where onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
onset Maybe (ConcreteVal tp)
_ ConcreteVal tp
x = case ConcreteVal tp -> Maybe help
vf ConcreteVal tp
x of
Maybe help
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
Just help
z -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty help
z
copyOpt :: (Text -> Text) -> ConfigDesc -> ConfigDesc
copyOpt :: (Text -> Text) -> ConfigDesc -> ConfigDesc
copyOpt Text -> Text
modName (ConfigDesc o :: ConfigOption tp
o@(ConfigOption BaseTypeRepr tp
ty NonEmpty Text
_) OptionStyle tp
sty Maybe (Doc Void)
h Maybe [ConfigDesc]
_) =
let newName :: NonEmpty Text
newName = case Text -> Maybe (NonEmpty Text)
splitPath (Text -> Text
modName (forall (tp :: BaseType). ConfigOption tp -> Text
configOptionText ConfigOption tp
o)) of
Just NonEmpty Text
ps -> NonEmpty Text
ps
Maybe (NonEmpty Text)
Nothing -> forall a. HasCallStack => String -> a
error String
"new config option must not be empty"
in forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe [ConfigDesc]
-> ConfigDesc
ConfigDesc (forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption BaseTypeRepr tp
ty NonEmpty Text
newName) OptionStyle tp
sty Maybe (Doc Void)
h forall a. Maybe a
Nothing
data ConfigLeaf where
ConfigLeaf ::
!(OptionStyle tp) ->
MVar (Maybe (ConcreteVal tp)) ->
Maybe (Doc Void) ->
ConfigLeaf
data ConfigTrie where
ConfigTrie ::
!(Maybe ConfigLeaf) ->
!ConfigMap ->
ConfigTrie
type ConfigMap = Map Text ConfigTrie
freshLeaf :: [Text] -> ConfigLeaf -> ConfigTrie
freshLeaf :: [Text] -> ConfigLeaf -> ConfigTrie
freshLeaf [] ConfigLeaf
l = Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie (forall a. a -> Maybe a
Just ConfigLeaf
l) forall a. Monoid a => a
mempty
freshLeaf (Text
a:[Text]
as) ConfigLeaf
l = Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie forall a. Maybe a
Nothing (forall k a. k -> a -> Map k a
Map.singleton Text
a ([Text] -> ConfigLeaf -> ConfigTrie
freshLeaf [Text]
as ConfigLeaf
l))
adjustConfigTrie :: Functor t => [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> Maybe (ConfigTrie) -> t (Maybe ConfigTrie)
adjustConfigTrie :: forall (t :: Type -> Type).
Functor t =>
[Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> Maybe ConfigTrie
-> t (Maybe ConfigTrie)
adjustConfigTrie [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f Maybe ConfigTrie
Nothing = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> ConfigLeaf -> ConfigTrie
freshLeaf [Text]
as) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f forall a. Maybe a
Nothing
adjustConfigTrie (Text
a:[Text]
as) Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f (Just (ConfigTrie Maybe ConfigLeaf
x ConfigMap
m)) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie Maybe ConfigLeaf
x forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
a [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f ConfigMap
m
adjustConfigTrie [] Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f (Just (ConfigTrie Maybe ConfigLeaf
x ConfigMap
m)) = Maybe ConfigLeaf -> Maybe ConfigTrie
g forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f Maybe ConfigLeaf
x
where g :: Maybe ConfigLeaf -> Maybe ConfigTrie
g Maybe ConfigLeaf
Nothing | forall k a. Map k a -> Bool
Map.null ConfigMap
m = forall a. Maybe a
Nothing
g Maybe ConfigLeaf
x' = forall a. a -> Maybe a
Just (Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie Maybe ConfigLeaf
x' ConfigMap
m)
adjustConfigMap :: Functor t => Text -> [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> ConfigMap -> t ConfigMap
adjustConfigMap :: forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
a [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f = forall (f :: Type -> Type) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (forall (t :: Type -> Type).
Functor t =>
[Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> Maybe ConfigTrie
-> t (Maybe ConfigTrie)
adjustConfigTrie [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f) Text
a
traverseConfigMap ::
Applicative t =>
[Text] ->
([Text] -> ConfigLeaf -> t ConfigLeaf) ->
ConfigMap ->
t ConfigMap
traverseConfigMap :: forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f = forall (t :: Type -> Type) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (\Text
k -> forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigTrie
-> t ConfigTrie
traverseConfigTrie (Text
kforall a. a -> [a] -> [a]
:[Text]
revPath) [Text] -> ConfigLeaf -> t ConfigLeaf
f)
traverseConfigTrie ::
Applicative t =>
[Text] ->
([Text] -> ConfigLeaf -> t ConfigLeaf) ->
ConfigTrie ->
t ConfigTrie
traverseConfigTrie :: forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigTrie
-> t ConfigTrie
traverseConfigTrie [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f (ConfigTrie Maybe ConfigLeaf
x ConfigMap
m) =
Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Text] -> ConfigLeaf -> t ConfigLeaf
f (forall a. [a] -> [a]
reverse [Text]
revPath)) Maybe ConfigLeaf
x forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f ConfigMap
m
traverseSubtree ::
Applicative t =>
[Text] ->
([Text] -> ConfigLeaf -> t ConfigLeaf) ->
ConfigMap ->
t ConfigMap
traverseSubtree :: forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseSubtree [Text]
ps0 [Text] -> ConfigLeaf -> t ConfigLeaf
f = [Text] -> [Text] -> ConfigMap -> t ConfigMap
go [Text]
ps0 []
where
go :: [Text] -> [Text] -> ConfigMap -> t ConfigMap
go [] [Text]
revPath = forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f
go (Text
p:[Text]
ps) [Text]
revPath = forall (f :: Type -> Type) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConfigTrie -> t ConfigTrie
g) Text
p
where g :: ConfigTrie -> t ConfigTrie
g (ConfigTrie Maybe ConfigLeaf
x ConfigMap
m) = Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
here Maybe ConfigLeaf
x forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Text] -> [Text] -> ConfigMap -> t ConfigMap
go [Text]
ps (Text
pforall a. a -> [a] -> [a]
:[Text]
revPath) ConfigMap
m
here :: Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
here = forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Text] -> ConfigLeaf -> t ConfigLeaf
f (forall a. [a] -> [a]
reverse (Text
pforall a. a -> [a] -> [a]
:[Text]
revPath)))
tryInsertOption ::
(MonadIO m, MonadCatch m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
tryInsertOption :: forall (m :: Type -> Type).
(MonadIO m, MonadCatch m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
tryInsertOption ConfigMap
m ConfigDesc
d =
forall (m :: Type -> Type) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: Type -> Type).
(MonadIO m, MonadThrow m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
insertOption ConfigMap
m ConfigDesc
d)
(\OptCreateFailure{} -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ConfigMap
m)
insertOption ::
(MonadIO m, MonadThrow m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
insertOption :: forall (m :: Type -> Type).
(MonadIO m, MonadThrow m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
insertOption ConfigMap
m d :: ConfigDesc
d@(ConfigDesc o :: ConfigOption tp
o@(ConfigOption BaseTypeRepr tp
_tp (Text
p:|[Text]
ps)) OptionStyle tp
sty Maybe (Doc Void)
h Maybe [ConfigDesc]
newRepls) =
forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
p [Text]
ps Maybe ConfigLeaf -> m (Maybe ConfigLeaf)
f ConfigMap
m
where
f :: Maybe ConfigLeaf -> m (Maybe ConfigLeaf)
f Maybe ConfigLeaf
Nothing =
let addOnSetWarning :: Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning Doc Void
warning OptionStyle tp
oldSty =
let newSty :: OptionStyle tp
newSty = forall (tp :: BaseType).
(Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
set_opt_onset Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
depF OptionStyle tp
oldSty
oldVF :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
oldVF = forall (tp :: BaseType).
OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset OptionStyle tp
oldSty
depF :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
depF Maybe (ConcreteVal tp)
oldV ConcreteVal tp
newV =
do OptionSetResult
v <- Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
oldVF Maybe (ConcreteVal tp)
oldV ConcreteVal tp
newV
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult
v forall a. Semigroup a => a -> a -> a
<> Doc Void -> OptionSetResult
optWarn Doc Void
warning)
in OptionStyle tp
newSty
deprHelp :: Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc ann
depMsg f (Doc ann)
ontoHelp =
let hMod :: Doc ann -> Doc ann
hMod Doc ann
oldHelp = forall ann. [Doc ann] -> Doc ann
vsep [ Doc ann
oldHelp, Doc ann
"*** DEPRECATED! ***", Doc ann
depMsg ]
in Doc ann -> Doc ann
hMod forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Doc ann)
ontoHelp
newRefs :: Doc ann -> [(a, ConfigLeaf)] -> Doc ann
newRefs Doc ann
tySep = forall ann. [Doc ann] -> Doc ann
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> [a] -> [b]
map (\(a
n, ConfigLeaf OptionStyle tp
s MVar (Maybe (ConcreteVal tp))
_ Maybe (Doc Void)
_) -> forall {a} {ann} {tp :: BaseType}.
Show a =>
Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc ann
tySep a
n OptionStyle tp
s)
optRef :: Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc ann
tySep a
nm OptionStyle tp
s = forall ann. [Doc ann] -> Doc ann
hcat [ forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show a
nm), Doc ann
tySep
, forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
s))
]
in case Maybe [ConfigDesc]
newRepls of
Maybe [ConfigDesc]
Nothing ->
do MVar (Maybe (ConcreteVal tp))
ref <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar (forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
h))
Just [] ->
do MVar (Maybe (ConcreteVal tp))
ref <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar (forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
let sty' :: OptionStyle tp
sty' = forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning
(Doc Void
"DEPRECATED CONFIG OPTION WILL BE IGNORED: " forall a. Semigroup a => a -> a -> a
<>
forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<>
Doc Void
" (no longer valid)")
OptionStyle tp
sty
hmsg :: Doc Void
hmsg = Doc Void
"Option '" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<> Doc Void
"' is no longer valid."
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf OptionStyle tp
sty' MVar (Maybe (ConcreteVal tp))
ref (forall {f :: Type -> Type} {ann}.
Functor f =>
Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc Void
hmsg Maybe (Doc Void)
h)))
Just [ConfigDesc]
n -> do
let newer :: [[Maybe (Text, ConfigLeaf)]]
newer =
let returnFnd :: Text -> [Text] -> b -> Const [Maybe (Text, b)] b
returnFnd Text
fnd [Text]
loc b
lf =
if [Text] -> Text
name [Text]
loc forall a. Eq a => a -> a -> Bool
== Text
fnd
then forall {k} a (b :: k). a -> Const a b
Const [forall a. a -> Maybe a
Just (Text
fnd, b
lf)]
else forall {k} a (b :: k). a -> Const a b
Const [forall a. Maybe a
Nothing]
name :: [Text] -> Text
name [Text]
parts = Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
parts
lookupNewer :: ConfigDesc -> [Maybe (Text, ConfigLeaf)]
lookupNewer (ConfigDesc (ConfigOption BaseTypeRepr tp
_ (Text
t:|[Text]
ts)) OptionStyle tp
_sty Maybe (Doc Void)
_h Maybe [ConfigDesc]
new2) =
case Maybe [ConfigDesc]
new2 of
Maybe [ConfigDesc]
Nothing -> forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [] (forall {k} {b} {b :: k}.
Text -> [Text] -> b -> Const [Maybe (Text, b)] b
returnFnd ([Text] -> Text
name (Text
tforall a. a -> [a] -> [a]
:[Text]
ts))) ConfigMap
m
Just [ConfigDesc]
n2 -> forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (ConfigDesc -> [Maybe (Text, ConfigLeaf)]
lookupNewer forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConfigDesc]
n2)
in ConfigDesc -> [Maybe (Text, ConfigLeaf)]
lookupNewer forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConfigDesc]
n
chkMissing :: [Maybe (Text, ConfigLeaf)] -> m [Maybe (Text, ConfigLeaf)]
chkMissing [Maybe (Text, ConfigLeaf)]
opts =
if Bool -> Bool
not (forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Maybe (Text, ConfigLeaf)]
opts) Bool -> Bool -> Bool
&& forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Text, ConfigLeaf)]
opts)
then forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ ConfigDesc -> Doc Void -> OptCreateFailure
OptCreateFailure ConfigDesc
d forall a b. (a -> b) -> a -> b
$
Doc Void
"replacement options must be inserted into" forall a. Semigroup a => a -> a -> a
<>
Doc Void
" Config before this deprecated option"
else forall (m :: Type -> Type) a. Monad m => a -> m a
return [Maybe (Text, ConfigLeaf)]
opts
[(Text, ConfigLeaf)]
newOpts <- forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Maybe (Text, ConfigLeaf)] -> m [Maybe (Text, ConfigLeaf)]
chkMissing [[Maybe (Text, ConfigLeaf)]]
newer
case [(Text, ConfigLeaf)]
newOpts of
[] ->
do MVar (Maybe (ConcreteVal tp))
ref <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar (forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
let sty' :: OptionStyle tp
sty' = forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning
(Doc Void
"DEPRECATED CONFIG OPTION WILL BE IGNORED: " forall a. Semigroup a => a -> a -> a
<>
forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<>
Doc Void
" (no longer valid)")
OptionStyle tp
sty
hmsg :: Doc Void
hmsg = Doc Void
"Option '" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<> Doc Void
"' is no longer valid."
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf OptionStyle tp
sty' MVar (Maybe (ConcreteVal tp))
ref (forall {f :: Type -> Type} {ann}.
Functor f =>
Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc Void
hmsg Maybe (Doc Void)
h)))
((Text
nm, ConfigLeaf OptionStyle tp
sty' MVar (Maybe (ConcreteVal tp))
v Maybe (Doc Void)
_):[])
| Just tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty') ->
do let updSty :: OptionStyle tp -> OptionStyle tp
updSty = forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning
(Doc Void
"DEPRECATED CONFIG OPTION USED: " forall a. Semigroup a => a -> a -> a
<>
forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<>
Doc Void
" (renamed to: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
nm forall a. Semigroup a => a -> a -> a
<> Doc Void
")")
hmsg :: Doc Void
hmsg = Doc Void
"Suggest replacing '" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show ConfigOption tp
o) forall a. Semigroup a => a -> a -> a
<>
Doc Void
"' with '" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
nm forall a. Semigroup a => a -> a -> a
<> Doc Void
"'."
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf (OptionStyle tp -> OptionStyle tp
updSty OptionStyle tp
sty) MVar (Maybe (ConcreteVal tp))
v (forall {f :: Type -> Type} {ann}.
Functor f =>
Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc Void
hmsg Maybe (Doc Void)
h)))
((Text, ConfigLeaf)
new1:[]) ->
do MVar (Maybe (ConcreteVal tp))
ref <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar (forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
let updSty :: OptionStyle tp -> OptionStyle tp
updSty = forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning
(Doc Void
"DEPRECATED CONFIG OPTION USED: " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann} {tp :: BaseType}.
Show a =>
Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc Void
"::" ConfigOption tp
o OptionStyle tp
sty forall a. Semigroup a => a -> a -> a
<>
Doc Void
" (changed to: " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann}. Show a => Doc ann -> [(a, ConfigLeaf)] -> Doc ann
newRefs Doc Void
"::" [(Text, ConfigLeaf)
new1] forall a. Semigroup a => a -> a -> a
<>
Doc Void
"); this value may be ignored")
hmsg :: Doc Void
hmsg = Doc Void
"Suggest converting '" forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann} {tp :: BaseType}.
Show a =>
Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc Void
" of type " ConfigOption tp
o OptionStyle tp
sty forall a. Semigroup a => a -> a -> a
<>
Doc Void
" to " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann}. Show a => Doc ann -> [(a, ConfigLeaf)] -> Doc ann
newRefs Doc Void
" of type " [(Text, ConfigLeaf)
new1]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf (OptionStyle tp -> OptionStyle tp
updSty OptionStyle tp
sty) MVar (Maybe (ConcreteVal tp))
ref (forall {f :: Type -> Type} {ann}.
Functor f =>
Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc Void
hmsg Maybe (Doc Void)
h)))
[(Text, ConfigLeaf)]
newMulti ->
do MVar (Maybe (ConcreteVal tp))
ref <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar (forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
let updSty :: OptionStyle tp -> OptionStyle tp
updSty = forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
addOnSetWarning
(Doc Void
"DEPRECATED CONFIG OPTION USED: " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann} {tp :: BaseType}.
Show a =>
Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc Void
"::" ConfigOption tp
o OptionStyle tp
sty forall a. Semigroup a => a -> a -> a
<>
Doc Void
" (replaced by: " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann}. Show a => Doc ann -> [(a, ConfigLeaf)] -> Doc ann
newRefs Doc Void
"::" [(Text, ConfigLeaf)]
newMulti forall a. Semigroup a => a -> a -> a
<>
Doc Void
"); this value may be ignored")
hmsg :: Doc Void
hmsg = Doc Void
"Suggest converting " forall a. Semigroup a => a -> a -> a
<>
forall {a} {ann} {tp :: BaseType}.
Show a =>
Doc ann -> a -> OptionStyle tp -> Doc ann
optRef Doc Void
" of type " ConfigOption tp
o OptionStyle tp
sty forall a. Semigroup a => a -> a -> a
<>
Doc Void
" to: " forall a. Semigroup a => a -> a -> a
<> (forall {a} {ann}. Show a => Doc ann -> [(a, ConfigLeaf)] -> Doc ann
newRefs Doc Void
" of type " [(Text, ConfigLeaf)]
newMulti)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
ConfigLeaf (OptionStyle tp -> OptionStyle tp
updSty OptionStyle tp
sty) MVar (Maybe (ConcreteVal tp))
ref (forall {f :: Type -> Type} {ann}.
Functor f =>
Doc ann -> f (Doc ann) -> f (Doc ann)
deprHelp Doc Void
hmsg Maybe (Doc Void)
h)))
f (Just existing :: ConfigLeaf
existing@(ConfigLeaf OptionStyle tp
sty' MVar (Maybe (ConcreteVal tp))
_ Maybe (Doc Void)
h')) =
case forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty') of
Just tp :~: tp
Refl ->
if forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and [ forall a. Show a => a -> String
show (forall (tp :: BaseType). OptionStyle tp -> Doc Void
opt_help OptionStyle tp
sty) forall a. Eq a => a -> a -> Bool
== forall a. Show a => a -> String
show (forall (tp :: BaseType). OptionStyle tp -> Doc Void
opt_help OptionStyle tp
sty')
, forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty forall a. Eq a => a -> a -> Bool
== forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty'
, forall a. Show a => a -> String
show Maybe (Doc Void)
h forall a. Eq a => a -> a -> Bool
== forall a. Show a => a -> String
show Maybe (Doc Void)
h'
]
then forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ConfigLeaf
existing
else forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ ConfigDesc -> Doc Void -> OptCreateFailure
OptCreateFailure ConfigDesc
d Doc Void
"already exists"
Maybe (tp :~: tp)
Nothing -> forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ ConfigDesc -> Doc Void -> OptCreateFailure
OptCreateFailure ConfigDesc
d
(forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ String
"already exists with type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty'))
data OptCreateFailure = OptCreateFailure ConfigDesc (Doc Void)
instance Exception OptCreateFailure
instance Show OptCreateFailure where
show :: OptCreateFailure -> String
show (OptCreateFailure ConfigDesc
cfgdesc Doc Void
msg) =
String
"Failed to create option " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ConfigDesc
cfgdesc forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Doc Void
msg
newtype Config = Config (RWV.RWVar ConfigMap)
initialConfig ::
Integer ->
[ConfigDesc] ->
IO (Config)
initialConfig :: Integer -> [ConfigDesc] -> IO Config
initialConfig Integer
initVerbosity [ConfigDesc]
ts = do
Config
cfg <- RWVar ConfigMap -> Config
Config forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (RWVar a)
RWV.new forall k a. Map k a
Map.empty
[ConfigDesc] -> Config -> IO ()
extendConfig (Integer -> [ConfigDesc]
builtInOpts Integer
initVerbosity forall a. [a] -> [a] -> [a]
++ [ConfigDesc]
ts) Config
cfg
forall (m :: Type -> Type) a. Monad m => a -> m a
return Config
cfg
extendConfig :: [ConfigDesc] -> Config -> IO ()
extendConfig :: [ConfigDesc] -> Config -> IO ()
extendConfig [ConfigDesc]
ts (Config RWVar ConfigMap
cfg) =
forall a. RWVar a -> (a -> IO a) -> IO ()
RWV.modify_ RWVar ConfigMap
cfg (\ConfigMap
m -> forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall (m :: Type -> Type).
(MonadIO m, MonadThrow m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
insertOption ConfigMap
m [ConfigDesc]
ts)
tryExtendConfig :: [ConfigDesc] -> Config -> IO ()
tryExtendConfig :: [ConfigDesc] -> Config -> IO ()
tryExtendConfig [ConfigDesc]
ts (Config RWVar ConfigMap
cfg) =
forall a. RWVar a -> (a -> IO a) -> IO ()
RWV.modify_ RWVar ConfigMap
cfg (\ConfigMap
m -> forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall (m :: Type -> Type).
(MonadIO m, MonadCatch m) =>
ConfigMap -> ConfigDesc -> m ConfigMap
tryInsertOption ConfigMap
m [ConfigDesc]
ts)
splitConfig :: Config -> IO Config
splitConfig :: Config -> IO Config
splitConfig (Config RWVar ConfigMap
cfg) = RWVar ConfigMap -> Config
Config forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. RWVar a -> (a -> IO b) -> IO b
RWV.with RWVar ConfigMap
cfg forall a. a -> IO (RWVar a)
RWV.new)
verbosity :: ConfigOption BaseIntegerType
verbosity :: ConfigOption BaseIntegerType
verbosity = forall (tp :: BaseType).
BaseTypeRepr tp -> String -> ConfigOption tp
configOption BaseTypeRepr BaseIntegerType
BaseIntegerRepr String
"verbosity"
builtInOpts :: Integer -> [ConfigDesc]
builtInOpts :: Integer -> [ConfigDesc]
builtInOpts Integer
initialVerbosity =
[ forall help (tp :: BaseType).
Pretty help =>
ConfigOption tp -> ConcreteVal tp -> help -> ConfigDesc
opt ConfigOption BaseIntegerType
verbosity
(Integer -> ConcreteVal BaseIntegerType
ConcreteInteger Integer
initialVerbosity)
(Text
"Verbosity of the simulator: higher values produce more detailed informational and debugging output." :: Text)
]
verbosityLogger :: Config -> Handle -> IO (Int -> String -> IO ())
verbosityLogger :: Config -> Handle -> IO (Int -> String -> IO ())
verbosityLogger Config
cfg Handle
h =
do OptionSetting BaseIntegerType
verb <- forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
getOptionSetting ConfigOption BaseIntegerType
verbosity Config
cfg
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Int
n String
msg ->
do Integer
v <- forall (tp :: BaseType) a. Opt tp a => OptionSetting tp -> IO a
getOpt OptionSetting BaseIntegerType
verb
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Integer
toInteger Int
n forall a. Ord a => a -> a -> Bool
< Integer
v) (Handle -> String -> IO ()
hPutStr Handle
h String
msg)
class Opt (tp :: BaseType) (a :: Type) | tp -> a where
getMaybeOpt :: OptionSetting tp -> IO (Maybe a)
trySetOpt :: OptionSetting tp -> a -> IO OptionSetResult
setOpt :: OptionSetting tp -> a -> IO [Doc Void]
setOpt OptionSetting tp
x a
v = forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> a -> IO OptionSetResult
trySetOpt OptionSetting tp
x a
v forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (tp :: BaseType).
OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetting tp
x
getOpt :: OptionSetting tp -> IO a
getOpt OptionSetting tp
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure (Some OptionSetting -> OptRef
OSet forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> Type) (x :: k). f x -> Some f
Some OptionSetting tp
x) Doc Void
"not set") forall (m :: Type -> Type) a. Monad m => a -> m a
return
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
getMaybeOpt OptionSetting tp
x
checkOptSetResult :: OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult :: forall (tp :: BaseType).
OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetting tp
optset OptionSetResult
res =
case OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res of
Just Doc Void
msg -> forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Some OptionSetting -> Doc Void -> OptSetFailure
OptSetFailure (forall k (f :: k -> Type) (x :: k). f x -> Some f
Some OptionSetting tp
optset) Doc Void
msg
Maybe (Doc Void)
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (OptionSetResult -> Seq (Doc Void)
optionSetWarnings OptionSetResult
res))
data OptSetFailure = OptSetFailure (Some OptionSetting) (Doc Void)
instance Exception OptSetFailure
instance Show OptSetFailure where
show :: OptSetFailure -> String
show (OptSetFailure Some OptionSetting
optset Doc Void
msg) =
String
"Failed to set " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Some OptionSetting
optset forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Doc Void
msg
data OptRef = OName Text | OSet (Some OptionSetting) | OCfg (Some ConfigOption)
instance Show OptRef where
show :: OptRef -> String
show = \case
OName Text
t -> forall a. Show a => a -> String
show Text
t
OSet (Some OptionSetting x
s) -> forall a. Show a => a -> String
show OptionSetting x
s
OCfg (Some ConfigOption x
c) -> forall a. Show a => a -> String
show ConfigOption x
c
data OptGetFailure = OptGetFailure OptRef (Doc Void)
instance Exception OptGetFailure
instance Show OptGetFailure where
show :: OptGetFailure -> String
show (OptGetFailure OptRef
optref Doc Void
msg) =
String
"Failed to get " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show OptRef
optref) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Doc Void
msg
instance Opt (BaseStringType Unicode) Text where
getMaybeOpt :: OptionSetting (BaseStringType Unicode) -> IO (Maybe Text)
getMaybeOpt OptionSetting (BaseStringType Unicode)
x = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (StringLiteral Unicode -> Text
fromUnicodeLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (si :: StringInfo).
ConcreteVal (BaseStringType si) -> StringLiteral si
fromConcreteString) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType).
OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption OptionSetting (BaseStringType Unicode)
x
trySetOpt :: OptionSetting (BaseStringType Unicode)
-> Text -> IO OptionSetResult
trySetOpt OptionSetting (BaseStringType Unicode)
x Text
v = forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting (BaseStringType Unicode)
x (forall (si :: StringInfo).
StringLiteral si -> ConcreteVal ('BaseStringType si)
ConcreteString (Text -> StringLiteral Unicode
UnicodeLiteral Text
v))
instance Opt BaseIntegerType Integer where
getMaybeOpt :: OptionSetting BaseIntegerType -> IO (Maybe Integer)
getMaybeOpt OptionSetting BaseIntegerType
x = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteVal BaseIntegerType -> Integer
fromConcreteInteger forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType).
OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption OptionSetting BaseIntegerType
x
trySetOpt :: OptionSetting BaseIntegerType -> Integer -> IO OptionSetResult
trySetOpt OptionSetting BaseIntegerType
x Integer
v = forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting BaseIntegerType
x (Integer -> ConcreteVal BaseIntegerType
ConcreteInteger Integer
v)
instance Opt BaseBoolType Bool where
getMaybeOpt :: OptionSetting BaseBoolType -> IO (Maybe Bool)
getMaybeOpt OptionSetting BaseBoolType
x = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteVal BaseBoolType -> Bool
fromConcreteBool forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType).
OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption OptionSetting BaseBoolType
x
trySetOpt :: OptionSetting BaseBoolType -> Bool -> IO OptionSetResult
trySetOpt OptionSetting BaseBoolType
x Bool
v = forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting BaseBoolType
x (Bool -> ConcreteVal BaseBoolType
ConcreteBool Bool
v)
instance Opt BaseRealType Rational where
getMaybeOpt :: OptionSetting BaseRealType -> IO (Maybe Rational)
getMaybeOpt OptionSetting BaseRealType
x = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteVal BaseRealType -> Rational
fromConcreteReal forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType).
OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption OptionSetting BaseRealType
x
trySetOpt :: OptionSetting BaseRealType -> Rational -> IO OptionSetResult
trySetOpt OptionSetting BaseRealType
x Rational
v = forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting BaseRealType
x (Rational -> ConcreteVal BaseRealType
ConcreteReal Rational
v)
setUnicodeOpt :: Some OptionSetting -> Text -> IO [Doc Void]
setUnicodeOpt :: Some OptionSetting -> Text -> IO [Doc Void]
setUnicodeOpt (Some OptionSetting x
optset) Text
val =
let tyOpt :: BaseTypeRepr x
tyOpt = forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType (forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName OptionSetting x
optset)
in case forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality BaseTypeRepr x
tyOpt (forall (si :: StringInfo).
StringInfoRepr si -> BaseTypeRepr ('BaseStringType si)
BaseStringRepr StringInfoRepr Unicode
UnicodeRepr) of
Just x :~: BaseStringType Unicode
Refl -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> a -> IO [Doc Void]
setOpt OptionSetting x
optset Text
val
Maybe (x :~: BaseStringType Unicode)
Nothing ->
forall (tp :: BaseType).
OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetting x
optset forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
Doc Void
"option type is a" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty BaseTypeRepr x
tyOpt forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"but given a text string"
setIntegerOpt :: Some OptionSetting -> Integer -> IO [Doc Void]
setIntegerOpt :: Some OptionSetting -> Integer -> IO [Doc Void]
setIntegerOpt (Some OptionSetting x
optset) Integer
val =
let tyOpt :: BaseTypeRepr x
tyOpt = forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType (forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName OptionSetting x
optset)
in case forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality BaseTypeRepr x
tyOpt BaseTypeRepr BaseIntegerType
BaseIntegerRepr of
Just x :~: BaseIntegerType
Refl -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> a -> IO [Doc Void]
setOpt OptionSetting x
optset Integer
val
Maybe (x :~: BaseIntegerType)
Nothing ->
forall (tp :: BaseType).
OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetting x
optset forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
Doc Void
"option type is a" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty BaseTypeRepr x
tyOpt forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"but given an integer"
setBoolOpt :: Some OptionSetting -> Bool -> IO [Doc Void]
setBoolOpt :: Some OptionSetting -> Bool -> IO [Doc Void]
setBoolOpt (Some OptionSetting x
optset) Bool
val =
let tyOpt :: BaseTypeRepr x
tyOpt = forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType (forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName OptionSetting x
optset)
in case forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality BaseTypeRepr x
tyOpt BaseTypeRepr BaseBoolType
BaseBoolRepr of
Just x :~: BaseBoolType
Refl -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> a -> IO [Doc Void]
setOpt OptionSetting x
optset Bool
val
Maybe (x :~: BaseBoolType)
Nothing ->
forall (tp :: BaseType).
OptionSetting tp -> OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetting x
optset forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr forall a b. (a -> b) -> a -> b
$
Doc Void
"option type is a" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty BaseTypeRepr x
tyOpt forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"but given a boolean"
getOptionSetting ::
ConfigOption tp ->
Config ->
IO (OptionSetting tp)
getOptionSetting :: forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
getOptionSetting o :: ConfigOption tp
o@(ConfigOption BaseTypeRepr tp
tp (Text
p:|[Text]
ps)) (Config RWVar ConfigMap
cfg) =
forall a b. RWVar a -> (a -> IO b) -> IO b
RWV.with RWVar ConfigMap
cfg (forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
p [Text]
ps Maybe ConfigLeaf
-> Const (IO (OptionSetting tp)) (Maybe ConfigLeaf)
f)
where
f :: Maybe ConfigLeaf
-> Const (IO (OptionSetting tp)) (Maybe ConfigLeaf)
f Maybe ConfigLeaf
Nothing = forall {k} a (b :: k). a -> Const a b
Const (forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure (Some ConfigOption -> OptRef
OCfg forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ConfigOption tp
o) Doc Void
"not found")
f (Just ConfigLeaf
x) = forall {k} a (b :: k). a -> Const a b
Const (ConfigLeaf -> IO (OptionSetting tp)
leafToSetting ConfigLeaf
x)
leafToSetting :: ConfigLeaf -> IO (OptionSetting tp)
leafToSetting (ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
_h)
| Just tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) BaseTypeRepr tp
tp = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
OptionSetting
{ optionSettingName :: ConfigOption tp
optionSettingName = ConfigOption tp
o
, getOption :: IO (Maybe (ConcreteVal tp))
getOption = forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
, setOption :: ConcreteVal tp -> IO OptionSetResult
setOption = \ConcreteVal tp
v -> forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (ConcreteVal tp))
ref forall a b. (a -> b) -> a -> b
$ \Maybe (ConcreteVal tp)
old ->
do OptionSetResult
res <- forall (tp :: BaseType).
OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset OptionStyle tp
sty Maybe (ConcreteVal tp)
old ConcreteVal tp
v
let new :: Maybe (ConcreteVal tp)
new = if (forall a. Maybe a -> Bool
isJust (OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res)) then Maybe (ConcreteVal tp)
old else (forall a. a -> Maybe a
Just ConcreteVal tp
v)
Maybe (ConcreteVal tp)
new seq :: forall a b. a -> b -> b
`seq` forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (ConcreteVal tp)
new, OptionSetResult
res)
}
| Bool
otherwise = forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure (Some ConfigOption -> OptRef
OCfg forall a b. (a -> b) -> a -> b
$ forall k (f :: k -> Type) (x :: k). f x -> Some f
Some ConfigOption tp
o)
(forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ String
"Type mismatch: " forall a. Semigroup a => a -> a -> a
<>
String
"expected '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show BaseTypeRepr tp
tp forall a. Semigroup a => a -> a -> a
<>
String
"' but found '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) forall a. Semigroup a => a -> a -> a
<> String
"'"
)
getOptionSettingFromText ::
Text ->
Config ->
IO (Some OptionSetting)
getOptionSettingFromText :: Text -> Config -> IO (Some OptionSetting)
getOptionSettingFromText Text
nm (Config RWVar ConfigMap
cfg) =
case Text -> Maybe (NonEmpty Text)
splitPath Text
nm of
Maybe (NonEmpty Text)
Nothing -> forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure (Text -> OptRef
OName Text
"") Doc Void
"Illegal empty name for option"
Just (Text
p:|[Text]
ps) -> forall a b. RWVar a -> (a -> IO b) -> IO b
RWV.with RWVar ConfigMap
cfg (forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
p [Text]
ps (forall {k} {m :: Type -> Type} {b :: k}.
MonadThrow m =>
NonEmpty Text
-> Maybe ConfigLeaf -> Const (m (Some OptionSetting)) b
f (Text
pforall a. a -> [a] -> NonEmpty a
:|[Text]
ps)))
where
f :: NonEmpty Text
-> Maybe ConfigLeaf -> Const (m (Some OptionSetting)) b
f (Text
p:|[Text]
ps) Maybe ConfigLeaf
Nothing = forall {k} a (b :: k). a -> Const a b
Const (forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure
(Text -> OptRef
OName (Text -> [Text] -> Text
Text.intercalate Text
"." (Text
pforall a. a -> [a] -> [a]
:[Text]
ps)))
Doc Void
"not found")
f NonEmpty Text
path (Just ConfigLeaf
x) = forall {k} a (b :: k). a -> Const a b
Const (forall {m :: Type -> Type}.
Monad m =>
NonEmpty Text -> ConfigLeaf -> m (Some OptionSetting)
leafToSetting NonEmpty Text
path ConfigLeaf
x)
leafToSetting :: NonEmpty Text -> ConfigLeaf -> m (Some OptionSetting)
leafToSetting NonEmpty Text
path (ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
_h) = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some OptionSetting
{ optionSettingName :: ConfigOption tp
optionSettingName = forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) NonEmpty Text
path
, getOption :: IO (Maybe (ConcreteVal tp))
getOption = forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
, setOption :: ConcreteVal tp -> IO OptionSetResult
setOption = \ConcreteVal tp
v -> forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (ConcreteVal tp))
ref forall a b. (a -> b) -> a -> b
$ \Maybe (ConcreteVal tp)
old ->
do OptionSetResult
res <- forall (tp :: BaseType).
OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset OptionStyle tp
sty Maybe (ConcreteVal tp)
old ConcreteVal tp
v
let new :: Maybe (ConcreteVal tp)
new = if (forall a. Maybe a -> Bool
isJust (OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res)) then Maybe (ConcreteVal tp)
old else (forall a. a -> Maybe a
Just ConcreteVal tp
v)
Maybe (ConcreteVal tp)
new seq :: forall a b. a -> b -> b
`seq` forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (ConcreteVal tp)
new, OptionSetResult
res)
}
data ConfigValue where
ConfigValue :: ConfigOption tp -> ConcreteVal tp -> ConfigValue
instance Pretty ConfigValue where
pretty :: forall ann. ConfigValue -> Doc ann
pretty (ConfigValue ConfigOption tp
option ConcreteVal tp
val) =
forall (tp :: BaseType) ann.
[Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting (forall (tp :: BaseType). ConfigOption tp -> [Text]
configOptionNameParts ConfigOption tp
option) (forall a. a -> Maybe a
Just ConcreteVal tp
val)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"::" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
option)
getConfigValues ::
Text ->
Config ->
IO [ConfigValue]
getConfigValues :: Text -> Config -> IO [ConfigValue]
getConfigValues Text
prefix (Config RWVar ConfigMap
cfg) =
forall a b. RWVar a -> (a -> IO b) -> IO b
RWV.with RWVar ConfigMap
cfg forall a b. (a -> b) -> a -> b
$ \ConfigMap
m ->
do let ps :: [Text]
ps = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
Text.null forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"." Text
prefix
f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf
f :: [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf
f [] ConfigLeaf
_ = forall (m :: Type -> Type) e a.
(MonadThrow m, Exception e) =>
e -> m a
throwM forall a b. (a -> b) -> a -> b
$ OptRef -> Doc Void -> OptGetFailure
OptGetFailure (Text -> OptRef
OName Text
prefix)
Doc Void
"illegal empty option prefix name"
f (Text
p:[Text]
path) l :: ConfigLeaf
l@(ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
_h) =
do forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just ConcreteVal tp
x -> forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (forall a. a -> Seq a
Seq.singleton (forall (tp :: BaseType).
ConfigOption tp -> ConcreteVal tp -> ConfigValue
ConfigValue (forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption (forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) (Text
pforall a. a -> [a] -> NonEmpty a
:|[Text]
path)) ConcreteVal tp
x))
Maybe (ConcreteVal tp)
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ConfigLeaf
l
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT (forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseSubtree [Text]
ps [Text] -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf
f ConfigMap
m)
ppSetting :: [Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting :: forall (tp :: BaseType) ann.
[Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting [Text]
nm Maybe (ConcreteVal tp)
v = forall ann. Int -> Doc ann -> Doc ann
fill Int
30 (forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
nm)
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\ConcreteVal tp
x -> Doc ann
" = " forall a. Semigroup a => a -> a -> a
<> forall (tp :: BaseType) ann. ConcreteVal tp -> Doc ann
ppConcrete ConcreteVal tp
x) Maybe (ConcreteVal tp)
v
)
ppOption :: [Text] -> OptionStyle tp -> Maybe (ConcreteVal tp) -> Maybe (Doc Void) -> Doc Void
ppOption :: forall (tp :: BaseType).
[Text]
-> OptionStyle tp
-> Maybe (ConcreteVal tp)
-> Maybe (Doc Void)
-> Doc Void
ppOption [Text]
nm OptionStyle tp
sty Maybe (ConcreteVal tp)
x Maybe (Doc Void)
help =
forall ann. [Doc ann] -> Doc ann
vcat
[ forall ann. Doc ann -> Doc ann
group forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
fillCat [forall (tp :: BaseType) ann.
[Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting [Text]
nm Maybe (ConcreteVal tp)
x, forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall (tp :: BaseType). OptionStyle tp -> Doc Void
opt_help OptionStyle tp
sty)]
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall ann. Int -> Doc ann -> Doc ann
indent Int
4) Maybe (Doc Void)
help
]
ppConfigLeaf :: [Text] -> ConfigLeaf -> IO (Doc Void)
ppConfigLeaf :: [Text] -> ConfigLeaf -> IO (Doc Void)
ppConfigLeaf [Text]
nm (ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
help) =
do Maybe (ConcreteVal tp)
x <- forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType).
[Text]
-> OptionStyle tp
-> Maybe (ConcreteVal tp)
-> Maybe (Doc Void)
-> Doc Void
ppOption [Text]
nm OptionStyle tp
sty Maybe (ConcreteVal tp)
x Maybe (Doc Void)
help
configHelp ::
Text ->
Config ->
IO [Doc Void]
configHelp :: Text -> Config -> IO [Doc Void]
configHelp Text
prefix (Config RWVar ConfigMap
cfg) =
forall a b. RWVar a -> (a -> IO b) -> IO b
RWV.with RWVar ConfigMap
cfg forall a b. (a -> b) -> a -> b
$ \ConfigMap
m ->
do let ps :: [Text]
ps = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
Text.null forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"." Text
prefix
f :: [Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf
f :: [Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf
f [Text]
nm ConfigLeaf
leaf = do Doc Void
d <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Text] -> ConfigLeaf -> IO (Doc Void)
ppConfigLeaf [Text]
nm ConfigLeaf
leaf)
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (forall a. a -> Seq a
Seq.singleton Doc Void
d)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ConfigLeaf
leaf
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT (forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseSubtree [Text]
ps [Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf
f ConfigMap
m))
prettyRational :: Rational -> Doc ann
prettyRational :: forall ann. Rational -> Doc ann
prettyRational = forall a ann. Show a => a -> Doc ann
viaShow