------------------------------------------------------------------------
-- |
-- Module      : What4.Config
-- Description : Declares attributes for simulator configuration settings.
-- Copyright   : (c) Galois, Inc 2015-2020
-- License     : BSD3
-- Maintainer  : Rob Dockins <rdockins@galois.com>
-- Stability   : provisional
--
-- This module provides access to persistent configuration settings, and
-- is designed for access both by Haskell client code of the What4 library,
-- and by users of the systems ultimately built using the library, for example,
-- from within a user-facing REPL.
--
-- Configurations are defined dynamically by combining a collection of
-- configuration option descriptions.  This allows disparate modules
-- to define their own configuration options, rather than having to
-- define the options for all modules in a central place.  Every
-- configuration option has a name, which consists of a nonempty
-- sequence of period-separated strings.  The intention is that option
-- names should conform to a namespace hierarchy both for
-- organizational purposes and to avoid namespace conflicts.  For
-- example, the options for an \"asdf\" module might be named as:
--
--    * asdf.widget
--    * asdf.frob
--    * asdf.max_bound
--
-- At runtime, a configuration consists of a collection of nested
-- finite maps corresponding to the namespace tree of the existing
-- options.  A configuration option may be queried or set either by
-- using a raw string representation of the name (see
-- @getOptionSettingFromText@), or by using a `ConfigOption` value
-- (using @getOptionSetting@), which provides a modicum of type-safety
-- over the basic dynamically-typed configuration maps.
--
-- Each option is associated with an \"option style\", which describes
-- the underlying type of the option (e.g., integer, boolean, string,
-- etc.) as well as the allowed settings of that value.  In addition,
-- options can take arbitrary actions when their values are changed in
-- the @opt_onset@ callback.
--
-- Every configuration comes with the built-in `verbosity`
-- configuration option pre-defined.  A `Config` value is constructed
-- using the `initialConfig` operation, which should be given the
-- initial verbosity value and a collection of configuration options
-- to install.  A configuration may be later extended with additional
-- options by using the `extendConfig` operation.
--
-- Example use (assuming the you wanted to use the z3 solver):
--
-- > import What4.Solver
-- >
-- > setupSolverConfig :: (IsExprBuilder sym) -> sym -> IO ()
-- > setupSolverConfig sym = do
-- >   let cfg = getConfiguration sym
-- >   extendConfig (solver_adapter_config_options z3Adapter) cfg
-- >   z3PathSetter <- getOptionSetting z3Path
-- >   res <- setOpt z3PathSetter "/usr/bin/z3"
-- >   assert (null res) (return ())
--
-- Developer's note: we might want to add the following operations:
--
--   * a method for \"unsetting\" options to restore the default state of an option
--   * a method for removing options from a configuration altogether
--       (i.e., to undo extendConfig)
--
--
-- Note regarding concurrency: the configuration data structures in this
-- module are implemented using MVars, and may safely be used in a multithreaded
-- way; configuration changes made in one thread will be visible to others
-- in a properly synchronized way.  Of course, if one desires to isolate
-- configuration changes in different threads from each other, separate
-- configuration objects are required. As noted in the documentation for
-- 'opt_onset', the validation procedures for options should not
-- look up the value of other options, or deadlock may occur.
------------------------------------------------------------------------------
{-# 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 TypeOperators #-}
module What4.Config
  ( -- * Names of properties
    ConfigOption
  , configOption
  , configOptionType
  , configOptionName
  , configOptionText
  , configOptionNameParts

    -- * Option settings
  , OptionSetting(..)
  , Opt(..)

    -- * Defining option styles
  , OptionStyle(..)
  , set_opt_default
  , set_opt_onset

    -- ** OptionSetResult
  , OptionSetResult(..)
  , optOK
  , optWarn
  , optErr
  , checkOptSetResult

    -- ** Option style templates
  , Bound(..)
  , boolOptSty
  , integerOptSty
  , realOptSty
  , stringOptSty
  , realWithRangeOptSty
  , realWithMinOptSty
  , realWithMaxOptSty
  , integerWithRangeOptSty
  , integerWithMinOptSty
  , integerWithMaxOptSty
  , enumOptSty
  , listOptSty
  , executablePathOptSty

    -- * Describing configuration options
  , ConfigDesc
  , mkOpt
  , opt
  , optV
  , optU
  , optUV

    -- * Building and manipulating configurations
  , Config
  , initialConfig
  , extendConfig

  , getOptionSetting
  , getOptionSettingFromText

    -- * Extracting entire subtrees of the current configuration
  , ConfigValue(..)
  , getConfigValues

    -- * Printing help messages for configuration options
  , configHelp

    -- * Verbosity
  , verbosity
  , verbosityLogger
  ) where

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail( MonadFail )
#endif

import           Control.Applicative (Const(..))
import           Control.Concurrent.MVar
import           Control.Exception
import           Control.Lens ((&))
import           Control.Monad.Identity
import           Control.Monad.IO.Class
import           Control.Monad.Writer.Strict hiding ((<>))
import           Data.Kind
import           Data.Maybe
import           Data.Typeable
import           Data.Foldable (toList)
import           Data.List.NonEmpty (NonEmpty(..))
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.Map (Map)
import qualified Data.Map.Strict as Map
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

-------------------------------------------------------------------------
-- ConfigOption

-- | A Haskell-land wrapper around the name of a configuration option.
--   Developers are encouraged to define and use `ConfigOption` values
--   to avoid two classes of errors: typos in configuration option names;
--   and dynamic type-cast failures.  Both classes of errors can be lifted
--   to statically-checkable failures (missing symbols and type-checking,
--   respectively) by consistently using `ConfigOption` values.
--
--   The following example indicates the suggested usage
--
-- @
--   asdfFrob :: ConfigOption BaseRealType
--   asdfFrob = configOption BaseRealRepr "asdf.frob"
--
--   asdfMaxBound :: ConfigOption BaseIntegerType
--   asdfMaxBound = configOption BaseIntegerRepr "asdf.max_bound"
-- @
data ConfigOption (tp :: BaseType) where
  ConfigOption :: BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp

instance Show (ConfigOption tp) where
  show :: ConfigOption tp -> String
show = ConfigOption tp -> String
forall (tp :: BaseType). ConfigOption tp -> String
configOptionName

-- | Construct a `ConfigOption` from a string name.  Idiomatic usage is
--   to define a single top-level `ConfigOption` value in the module where the option
--   is defined to consistently fix its name and type for all subsequent uses.
configOption :: BaseTypeRepr tp -> String -> ConfigOption tp
configOption :: 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 -> BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption BaseTypeRepr tp
tp NonEmpty Text
ps
    Maybe (NonEmpty Text)
Nothing -> String -> ConfigOption tp
forall a. HasCallStack => String -> a
error String
"config options cannot have an empty name"

-- | Split a text value on \' characters.  Return @Nothing@ if
--   the whole string, or any of its segments, is the empty string.
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) | (Text -> Bool) -> [Text] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs) -> NonEmpty Text -> Maybe (NonEmpty Text)
forall a. a -> Maybe a
Just (Text
xText -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:|[Text]
xs)
     [Text]
_ -> Maybe (NonEmpty Text)
forall a. Maybe a
Nothing

-- | Get the individual dot-separated segments of an option's name.
configOptionNameParts :: ConfigOption tp -> [Text]
configOptionNameParts :: ConfigOption tp -> [Text]
configOptionNameParts (ConfigOption BaseTypeRepr tp
_ (Text
x:|[Text]
xs)) = Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs

-- | Reconstruct the original string name of this option.
configOptionName :: ConfigOption tp -> String
configOptionName :: ConfigOption tp -> String
configOptionName = Text -> String
Text.unpack (Text -> String)
-> (ConfigOption tp -> Text) -> ConfigOption tp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigOption tp -> Text
forall (tp :: BaseType). ConfigOption tp -> Text
configOptionText

-- | Reconstruct the original string name of this option.
configOptionText :: ConfigOption tp -> Text
configOptionText :: ConfigOption tp -> Text
configOptionText (ConfigOption BaseTypeRepr tp
_ (Text
x:|[Text]
xs)) = Text -> [Text] -> Text
Text.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs)

-- | Retrieve the run-time type representation of @tp@.
configOptionType :: ConfigOption tp -> BaseTypeRepr tp
configOptionType :: ConfigOption tp -> BaseTypeRepr tp
configOptionType (ConfigOption BaseTypeRepr tp
tp NonEmpty Text
_) = BaseTypeRepr tp
tp

------------------------------------------------------------------------------
-- OptionSetResult

-- | When setting the value of an option, a validation function is called
--   (as defined by the associated @OptionStyle@).  The result of the validation
--   function is an @OptionSetResult@.  If the option value given is invalid
--   for some reason, an error should be returned.  Additionally, warning messages
--   may be returned, which will be passed through to the eventual call site
--   attempting to alter the option setting.
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 :: Maybe (Doc Void) -> Seq (Doc Void) -> OptionSetResult
OptionSetResult
            { optionSetError :: Maybe (Doc Void)
optionSetError    = OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
x Maybe (Doc Void) -> Maybe (Doc Void) -> Maybe (Doc Void)
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 Seq (Doc Void) -> Seq (Doc Void) -> Seq (Doc Void)
forall a. Semigroup a => a -> a -> a
<> OptionSetResult -> Seq (Doc Void)
optionSetWarnings OptionSetResult
y
            }

instance Monoid OptionSetResult where
  mappend :: OptionSetResult -> OptionSetResult -> OptionSetResult
mappend = OptionSetResult -> OptionSetResult -> OptionSetResult
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: OptionSetResult
mempty  = OptionSetResult
optOK

-- | Accept the new option value with no errors or warnings.
optOK :: OptionSetResult
optOK :: OptionSetResult
optOK = OptionSetResult :: Maybe (Doc Void) -> Seq (Doc Void) -> OptionSetResult
OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = Maybe (Doc Void)
forall a. Maybe a
Nothing, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = Seq (Doc Void)
forall a. Monoid a => a
mempty }

-- | Reject the new option value with an error message.
optErr :: Doc Void -> OptionSetResult
optErr :: Doc Void -> OptionSetResult
optErr Doc Void
x = OptionSetResult :: Maybe (Doc Void) -> Seq (Doc Void) -> OptionSetResult
OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = Doc Void -> Maybe (Doc Void)
forall a. a -> Maybe a
Just Doc Void
x, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = Seq (Doc Void)
forall a. Monoid a => a
mempty }

-- | Accept the given option value, but report a warning message.
optWarn :: Doc Void -> OptionSetResult
optWarn :: Doc Void -> OptionSetResult
optWarn Doc Void
x = OptionSetResult :: Maybe (Doc Void) -> Seq (Doc Void) -> OptionSetResult
OptionSetResult{ optionSetError :: Maybe (Doc Void)
optionSetError = Maybe (Doc Void)
forall a. Maybe a
Nothing, optionSetWarnings :: Seq (Doc Void)
optionSetWarnings = Doc Void -> Seq (Doc Void)
forall a. a -> Seq a
Seq.singleton Doc Void
x }


-- | An @OptionSetting@ gives the direct ability to query or set the current value
--   of an option.  The @getOption@ field is an action that, when executed, fetches
--   the current value of the option, if it is set.  The @setOption@ method attempts
--   to set the value of the option.  If the associated @opt_onset@ validation method
--   rejects the option, it will retain its previous value; otherwise it will be set
--   to the given value.  In either case, the generated @OptionSetResult@ will be
--   returned.
data OptionSetting (tp :: BaseType) =
  OptionSetting
  { OptionSetting tp -> ConfigOption tp
optionSettingName :: ConfigOption tp
  , OptionSetting tp -> IO (Maybe (ConcreteVal tp))
getOption :: IO (Maybe (ConcreteVal tp))
  , OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption :: ConcreteVal tp -> IO OptionSetResult
  }


-- | An option defines some metadata about how a configuration option behaves.
--   It contains a base type representation, which defines the runtime type
--   that is expected for setting and querying this option at runtime.
data OptionStyle (tp :: BaseType) =
  OptionStyle
  { OptionStyle tp -> BaseTypeRepr tp
opt_type :: BaseTypeRepr tp
    -- ^ base type representation of this option

  , OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset :: Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
    -- ^ An operation for validating new option values.  This action may also
    -- be used to take actions whenever an option setting is changed.  NOTE!
    -- the onset action should not attempt to look up the values of other
    -- configuration settings, or deadlock may occur.
    --
    -- The first argument is the current value of the option (if any).
    -- The second argument is the new value that is being set.
    -- If the validation fails, the operation should return a result
    -- describing why validation failed. Optionally, warnings may also be returned.

  , OptionStyle tp -> Doc Void
opt_help :: Doc Void
    -- ^ Documentation for the option to be displayed in the event a user asks for information
    --   about this option.  This message should contain information relevant to all options in this
    --   style (e.g., its type and range of expected values), not necessarily
    --   information about a specific option.

  , OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value :: Maybe (ConcreteVal tp)
    -- ^ This gives a default value for the option, if set.
  }

-- | A basic option style for the given base type.
--   This option style performs no validation, has no
--   help information, and has no default value.
defaultOpt :: BaseTypeRepr tp -> OptionStyle tp
defaultOpt :: BaseTypeRepr tp -> OptionStyle tp
defaultOpt BaseTypeRepr tp
tp =
  OptionStyle :: forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle 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
_ -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
forall a. Monoid a => a
mempty
  , opt_help :: Doc Void
opt_help = Doc Void
forall a. Monoid a => a
mempty
  , opt_default_value :: Maybe (ConcreteVal tp)
opt_default_value = Maybe (ConcreteVal tp)
forall a. Maybe a
Nothing
  }

-- | Update the @opt_onset@ field.
set_opt_onset :: (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
                 -> OptionStyle tp
                 -> OptionStyle tp
set_opt_onset :: (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 }

-- | Update the @opt_help@ field.
set_opt_help :: Doc Void
             -> OptionStyle tp
             -> OptionStyle tp
set_opt_help :: 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 }

-- | Update the @opt_default_value@ field.
set_opt_default :: ConcreteVal tp
              -> OptionStyle tp
              -> OptionStyle tp
set_opt_default :: 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 = ConcreteVal tp -> Maybe (ConcreteVal tp)
forall a. a -> Maybe a
Just ConcreteVal tp
v }


-- | An inclusive or exclusive bound.
data Bound r = Exclusive r
             | Inclusive r
             | Unbounded

-- | Standard option style for boolean-valued configuration options
boolOptSty :: OptionStyle BaseBoolType
boolOptSty :: OptionStyle BaseBoolType
boolOptSty = BaseTypeRepr BaseBoolType
-> (Maybe (ConcreteVal BaseBoolType)
    -> ConcreteVal BaseBoolType -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal BaseBoolType)
-> OptionStyle BaseBoolType
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
_ -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
                        Doc Void
"Boolean"
                        Maybe (ConcreteVal BaseBoolType)
forall a. Maybe a
Nothing

-- | Standard option style for real-valued configuration options
realOptSty :: OptionStyle BaseRealType
realOptSty :: OptionStyle BaseRealType
realOptSty = BaseTypeRepr BaseRealType
-> (Maybe (ConcreteVal BaseRealType)
    -> ConcreteVal BaseRealType -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal BaseRealType)
-> OptionStyle BaseRealType
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
_ -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
                  Doc Void
"ℝ"
                  Maybe (ConcreteVal BaseRealType)
forall a. Maybe a
Nothing

-- | Standard option style for integral-valued configuration options
integerOptSty :: OptionStyle BaseIntegerType
integerOptSty :: OptionStyle BaseIntegerType
integerOptSty = BaseTypeRepr BaseIntegerType
-> (Maybe (ConcreteVal BaseIntegerType)
    -> ConcreteVal BaseIntegerType -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal BaseIntegerType)
-> OptionStyle BaseIntegerType
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
_ -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
                  Doc Void
"ℤ"
                  Maybe (ConcreteVal BaseIntegerType)
forall a. Maybe a
Nothing

stringOptSty :: OptionStyle (BaseStringType Unicode)
stringOptSty :: OptionStyle (BaseStringType Unicode)
stringOptSty = BaseTypeRepr (BaseStringType Unicode)
-> (Maybe (ConcreteVal (BaseStringType Unicode))
    -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall (tp :: BaseType).
BaseTypeRepr tp
-> (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> Doc Void
-> Maybe (ConcreteVal tp)
-> OptionStyle tp
OptionStyle (StringInfoRepr Unicode -> BaseTypeRepr (BaseStringType Unicode)
forall (si :: StringInfo).
StringInfoRepr si -> BaseTypeRepr (BaseStringType si)
BaseStringRepr StringInfoRepr Unicode
UnicodeRepr)
                  (\Maybe (ConcreteVal (BaseStringType Unicode))
_ ConcreteVal (BaseStringType Unicode)
_ -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK)
                  Doc Void
"string"
                  Maybe (ConcreteVal (BaseStringType Unicode))
forall a. Maybe a
Nothing

checkBound :: Ord a => Bound a -> Bound a -> a -> Bool
checkBound :: Bound a -> Bound a -> a -> Bool
checkBound Bound a
lo Bound a
hi a
a = Bound a -> a -> Bool
forall a. Ord a => Bound a -> a -> Bool
checkLo Bound a
lo a
a Bool -> Bool -> Bool
&& a -> Bound a -> 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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
       checkLo (Exclusive a
x) a
y = a
x a -> a -> Bool
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
       checkHi a
x (Exclusive a
y) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<  a
y

docInterval :: Show a => Bound a -> Bound a -> Doc ann
docInterval :: Bound a -> Bound a -> Doc ann
docInterval Bound a
lo Bound a
hi = Bound a -> Doc ann
forall a ann. Show a => Bound a -> Doc ann
docLo Bound a
lo Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Bound a -> Doc ann
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
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow a
r
       docLo (Inclusive a
r)  = Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
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)  = a -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow a
r Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
       docHi (Inclusive a
r)  = a -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow a
r Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"


-- | Option style for real-valued options with upper and lower bounds
realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty :: Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty Bound Rational
lo Bound Rational
hi = OptionStyle BaseRealType
realOptSty OptionStyle BaseRealType
-> (OptionStyle BaseRealType -> OptionStyle BaseRealType)
-> OptionStyle BaseRealType
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal BaseRealType)
 -> ConcreteVal BaseRealType -> IO OptionSetResult)
-> OptionStyle BaseRealType -> OptionStyle BaseRealType
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
                                       OptionStyle BaseRealType
-> (OptionStyle BaseRealType -> OptionStyle BaseRealType)
-> OptionStyle BaseRealType
forall a b. a -> (a -> b) -> b
& Doc Void -> OptionStyle BaseRealType -> OptionStyle BaseRealType
forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
  where help :: Doc Void
help = Doc Void
"ℝ ∈" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bound Rational -> Bound Rational -> Doc Void
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)
          | Bound Rational -> Bound Rational -> Rational -> Bool
forall a. Ord a => Bound a -> Bound a -> a -> Bool
checkBound Bound Rational
lo Bound Rational
hi Rational
x = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
          | Bool
otherwise          = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$
                                 Rational -> Doc Void
forall ann. Rational -> Doc ann
prettyRational Rational
x Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"out of range, expected real value in "
                                                  Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bound Rational -> Bound Rational -> Doc Void
forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Rational
lo Bound Rational
hi

-- | Option style for real-valued options with a lower bound
realWithMinOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMinOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMinOptSty Bound Rational
lo = Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty Bound Rational
lo Bound Rational
forall r. Bound r
Unbounded

-- | Option style for real-valued options with an upper bound
realWithMaxOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMaxOptSty :: Bound Rational -> OptionStyle BaseRealType
realWithMaxOptSty Bound Rational
hi = Bound Rational -> Bound Rational -> OptionStyle BaseRealType
realWithRangeOptSty Bound Rational
forall r. Bound r
Unbounded Bound Rational
hi

-- | Option style for integer-valued options with upper and lower bounds
integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty :: Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty Bound Integer
lo Bound Integer
hi = OptionStyle BaseIntegerType
integerOptSty OptionStyle BaseIntegerType
-> (OptionStyle BaseIntegerType -> OptionStyle BaseIntegerType)
-> OptionStyle BaseIntegerType
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal BaseIntegerType)
 -> ConcreteVal BaseIntegerType -> IO OptionSetResult)
-> OptionStyle BaseIntegerType -> OptionStyle BaseIntegerType
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
                                              OptionStyle BaseIntegerType
-> (OptionStyle BaseIntegerType -> OptionStyle BaseIntegerType)
-> OptionStyle BaseIntegerType
forall a b. a -> (a -> b) -> b
& Doc Void
-> OptionStyle BaseIntegerType -> OptionStyle BaseIntegerType
forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
  where help :: Doc Void
help = Doc Void
"ℤ ∈" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bound Integer -> Bound Integer -> Doc Void
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)
          | Bound Integer -> Bound Integer -> Integer -> Bool
forall a. Ord a => Bound a -> Bound a -> a -> Bool
checkBound Bound Integer
lo Bound Integer
hi Integer
x = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
          | Bool
otherwise          = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$
                                 Integer -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Integer
x Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void
"out of range, expected integer value in "
                                          Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bound Integer -> Bound Integer -> Doc Void
forall a ann. Show a => Bound a -> Bound a -> Doc ann
docInterval Bound Integer
lo Bound Integer
hi

-- | Option style for integer-valued options with a lower bound
integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMinOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMinOptSty Bound Integer
lo = Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty Bound Integer
lo Bound Integer
forall r. Bound r
Unbounded

-- | Option style for integer-valued options with an upper bound
integerWithMaxOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMaxOptSty :: Bound Integer -> OptionStyle BaseIntegerType
integerWithMaxOptSty Bound Integer
hi = Bound Integer -> Bound Integer -> OptionStyle BaseIntegerType
integerWithRangeOptSty Bound Integer
forall r. Bound r
Unbounded Bound Integer
hi

-- | A configuration style for options that must be one of a fixed set of text values
enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode)
enumOptSty :: Set Text -> OptionStyle (BaseStringType Unicode)
enumOptSty Set Text
elts = OptionStyle (BaseStringType Unicode)
stringOptSty OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal (BaseStringType Unicode))
 -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult)
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
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
                               OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& Doc Void
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
  where help :: Doc Void
help = Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
group (Doc Void
"one of: " Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
align ([Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
sep ([Doc Void] -> Doc Void) -> [Doc Void] -> Doc Void
forall a b. (a -> b) -> a -> b
$ (Text -> Doc Void) -> [Text] -> [Doc Void]
forall a b. (a -> b) -> [a] -> [b]
map (Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
dquotes (Doc Void -> Doc Void) -> (Text -> Doc Void) -> Text -> Doc Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty) ([Text] -> [Doc Void]) -> [Text] -> [Doc Void]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
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 Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
elts = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
         | Bool
otherwise = OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$
                            Doc Void
"invalid setting" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
dquotes (Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Text
x) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                            Doc Void
", expected one of:" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                            Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
align ([Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
sep ((Text -> Doc Void) -> [Text] -> [Doc Void]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc Void]) -> [Text] -> [Doc Void]
forall a b. (a -> b) -> a -> b
$ Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
elts))

-- | A configuration syle for options that must be one of a fixed set of text values.
--   Associated with each string is a validation/callback action that will be run
--   whenever the named string option is selected.
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 OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal (BaseStringType Unicode))
 -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult)
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
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
                                  OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& Doc Void
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
forall (tp :: BaseType).
Doc Void -> OptionStyle tp -> OptionStyle tp
set_opt_help Doc Void
help
  where help :: Doc Void
help = Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
group (Doc Void
"one of: " Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
align ([Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
sep ([Doc Void] -> Doc Void) -> [Doc Void] -> Doc Void
forall a b. (a -> b) -> a -> b
$ ((Text, IO OptionSetResult) -> Doc Void)
-> [(Text, IO OptionSetResult)] -> [Doc Void]
forall a b. (a -> b) -> [a] -> [b]
map (Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
dquotes (Doc Void -> Doc Void)
-> ((Text, IO OptionSetResult) -> Doc Void)
-> (Text, IO OptionSetResult)
-> Doc Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc Void)
-> ((Text, IO OptionSetResult) -> Text)
-> (Text, IO OptionSetResult)
-> Doc Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, IO OptionSetResult) -> Text
forall a b. (a, b) -> a
fst) ([(Text, IO OptionSetResult)] -> [Doc Void])
-> [(Text, IO OptionSetResult)] -> [Doc Void]
forall a b. (a -> b) -> a -> b
$ Map Text (IO OptionSetResult) -> [(Text, IO OptionSetResult)]
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)) =
         IO OptionSetResult
-> Maybe (IO OptionSetResult) -> IO OptionSetResult
forall a. a -> Maybe a -> a
fromMaybe
          (OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$
            Doc Void
"invalid setting" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
dquotes (Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty Text
x) Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
            Doc Void
", expected one of:" Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
            Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
align ([Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
sep (((Text, IO OptionSetResult) -> Doc Void)
-> [(Text, IO OptionSetResult)] -> [Doc Void]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc Void)
-> ((Text, IO OptionSetResult) -> Text)
-> (Text, IO OptionSetResult)
-> Doc Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, IO OptionSetResult) -> Text
forall a b. (a, b) -> a
fst) ([(Text, IO OptionSetResult)] -> [Doc Void])
-> [(Text, IO OptionSetResult)] -> [Doc Void]
forall a b. (a -> b) -> a -> b
$ Map Text (IO OptionSetResult) -> [(Text, IO OptionSetResult)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (IO OptionSetResult)
values)))
          (Text -> Map Text (IO OptionSetResult) -> Maybe (IO OptionSetResult)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
x Map Text (IO OptionSetResult)
values)


-- | A configuration style for options that are expected to be paths to an executable
--   image.  Configuration options with this style generate a warning message if set to a
--   value that cannot be resolved to an absolute path to an executable file in the
--   current OS environment.
executablePathOptSty :: OptionStyle (BaseStringType Unicode)
executablePathOptSty :: OptionStyle (BaseStringType Unicode)
executablePathOptSty = OptionStyle (BaseStringType Unicode)
stringOptSty OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal (BaseStringType Unicode))
 -> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult)
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
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
                                    OptionStyle (BaseStringType Unicode)
-> (OptionStyle (BaseStringType Unicode)
    -> OptionStyle (BaseStringType Unicode))
-> OptionStyle (BaseStringType Unicode)
forall a b. a -> (a -> b) -> b
& Doc Void
-> OptionStyle (BaseStringType Unicode)
-> OptionStyle (BaseStringType Unicode)
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 <- IO String -> IO (Either IOError String)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO String
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{} -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ OptionSetResult
optOK
                       Left IOError
e  -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optWarn (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$ String -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc Void) -> String -> Doc Void
forall a b. (a -> b) -> a -> b
$ IOError -> String
ioeGetErrorString IOError
e


-- | A @ConfigDesc@ describes a configuration option before it is installed into
--   a @Config@ object.  It consists of a @ConfigOption@ name for the option,
--   an @OptionStyle@ describing the sort of option it is, and an optional
--   help message describing the semantics of this option.
data ConfigDesc where
  ConfigDesc :: ConfigOption tp -> OptionStyle tp -> Maybe (Doc Void) -> ConfigDesc

-- | The most general method for constructing a normal `ConfigDesc`.
mkOpt :: ConfigOption tp     -- ^ Fixes the name and the type of this option
      -> OptionStyle tp      -- ^ Define the style of this option
      -> Maybe (Doc Void)    -- ^ Help text
      -> Maybe (ConcreteVal tp) -- ^ A default value for this option
      -> ConfigDesc
mkOpt :: 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 = ConfigOption tp -> OptionStyle tp -> Maybe (Doc Void) -> ConfigDesc
forall (tp :: BaseType).
ConfigOption tp -> OptionStyle tp -> Maybe (Doc Void) -> 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

-- | Construct an option using a default style with a given initial value
opt :: Pretty help
    => ConfigOption tp      -- ^ Fixes the name and the type of this option
    -> ConcreteVal tp       -- ^ Default value for the option
    -> help                 -- ^ An informational message describing this option
    -> ConfigDesc
opt :: ConfigOption tp -> ConcreteVal tp -> help -> ConfigDesc
opt ConfigOption tp
o ConcreteVal tp
a help
help = ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (BaseTypeRepr tp -> OptionStyle tp
forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (ConfigOption tp -> BaseTypeRepr tp
forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o))
                       (Doc Void -> Maybe (Doc Void)
forall a. a -> Maybe a
Just (help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
help))
                       (ConcreteVal tp -> Maybe (ConcreteVal tp)
forall a. a -> Maybe a
Just ConcreteVal tp
a)

-- | Construct an option using a default style with a given initial value.
--   Also provide a validation function to check new values as they are set.
optV :: forall tp help
      . Pretty help
     => ConfigOption tp      -- ^ Fixes the name and the type of this option
     -> ConcreteVal tp       -- ^ Default value for the option
     -> (ConcreteVal tp -> Maybe help)
         -- ^ Validation function.  Return `Just err` if the value to set
         --   is not valid.
     -> help                -- ^ An informational message describing this option
     -> ConfigDesc
optV :: ConfigOption tp
-> ConcreteVal tp
-> (ConcreteVal tp -> Maybe help)
-> help
-> ConfigDesc
optV ConfigOption tp
o ConcreteVal tp
a ConcreteVal tp -> Maybe help
vf help
h = ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (BaseTypeRepr tp -> OptionStyle tp
forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (ConfigOption tp -> BaseTypeRepr tp
forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)
                           OptionStyle tp
-> (OptionStyle tp -> OptionStyle tp) -> OptionStyle tp
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
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)
                        (Doc Void -> Maybe (Doc Void)
forall a. a -> Maybe a
Just (help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
h))
                        (ConcreteVal tp -> Maybe (ConcreteVal tp)
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 -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
                       Just help
z  -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$ help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
z

-- | Construct an option using a default style with no initial value.
optU :: Pretty help
     => ConfigOption tp    -- ^ Fixes the name and the type of this option
     -> help               -- ^ An informational message describing this option
     -> ConfigDesc
optU :: ConfigOption tp -> help -> ConfigDesc
optU ConfigOption tp
o help
h = ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (BaseTypeRepr tp -> OptionStyle tp
forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (ConfigOption tp -> BaseTypeRepr tp
forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)) (Doc Void -> Maybe (Doc Void)
forall a. a -> Maybe a
Just (help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
h)) Maybe (ConcreteVal tp)
forall a. Maybe a
Nothing

-- | Construct an option using a default style with no initial value.
--   Also provide a validation function to check new values as they are set.
optUV :: forall help tp.
   Pretty help =>
   ConfigOption tp {- ^ Fixes the name and the type of this option -} ->
   (ConcreteVal tp -> Maybe help) {- ^ Validation function.  Return `Just err` if the value to set is not valid. -} ->
   help                {- ^ An informational message describing this option -} ->
   ConfigDesc
optUV :: ConfigOption tp
-> (ConcreteVal tp -> Maybe help) -> help -> ConfigDesc
optUV ConfigOption tp
o ConcreteVal tp -> Maybe help
vf help
h = ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
forall (tp :: BaseType).
ConfigOption tp
-> OptionStyle tp
-> Maybe (Doc Void)
-> Maybe (ConcreteVal tp)
-> ConfigDesc
mkOpt ConfigOption tp
o (BaseTypeRepr tp -> OptionStyle tp
forall (tp :: BaseType). BaseTypeRepr tp -> OptionStyle tp
defaultOpt (ConfigOption tp -> BaseTypeRepr tp
forall (tp :: BaseType). ConfigOption tp -> BaseTypeRepr tp
configOptionType ConfigOption tp
o)
                            OptionStyle tp
-> (OptionStyle tp -> OptionStyle tp) -> OptionStyle tp
forall a b. a -> (a -> b) -> b
& (Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult)
-> OptionStyle tp -> OptionStyle tp
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)
                       (Doc Void -> Maybe (Doc Void)
forall a. a -> Maybe a
Just (help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
h))
                       Maybe (ConcreteVal tp)
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 -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return OptionSetResult
optOK
                       Just help
z  -> OptionSetResult -> IO OptionSetResult
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetResult -> IO OptionSetResult)
-> OptionSetResult -> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ Doc Void -> OptionSetResult
optErr (Doc Void -> OptionSetResult) -> Doc Void -> OptionSetResult
forall a b. (a -> b) -> a -> b
$ help -> Doc Void
forall a ann. Pretty a => a -> Doc ann
pretty help
z

------------------------------------------------------------------------
-- ConfigState

data ConfigLeaf where
  ConfigLeaf ::
    !(OptionStyle tp)              {- Style for this option -} ->
    MVar (Maybe (ConcreteVal tp)) {- State of the option -} ->
    Maybe (Doc Void)               {- Help text for the option -} ->
    ConfigLeaf

-- | Main configuration data type.  It is organized as a trie based on the
--   name segments of the configuration option name.
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 (ConfigLeaf -> Maybe ConfigLeaf
forall a. a -> Maybe a
Just ConfigLeaf
l) ConfigMap
forall a. Monoid a => a
mempty
freshLeaf (Text
a:[Text]
as) ConfigLeaf
l = Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie Maybe ConfigLeaf
forall a. Maybe a
Nothing (Text -> ConfigTrie -> ConfigMap
forall k a. k -> a -> Map k a
Map.singleton Text
a ([Text] -> ConfigLeaf -> ConfigTrie
freshLeaf [Text]
as ConfigLeaf
l))

-- | The given list of name segments defines a lens into a config trie.
adjustConfigTrie :: Functor t => [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> Maybe (ConfigTrie) -> t (Maybe ConfigTrie)
adjustConfigTrie :: [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> Maybe ConfigTrie
-> t (Maybe ConfigTrie)
adjustConfigTrie     [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f Maybe ConfigTrie
Nothing                 = (ConfigLeaf -> ConfigTrie) -> Maybe ConfigLeaf -> Maybe ConfigTrie
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> ConfigLeaf -> ConfigTrie
freshLeaf [Text]
as) (Maybe ConfigLeaf -> Maybe ConfigTrie)
-> t (Maybe ConfigLeaf) -> t (Maybe ConfigTrie)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f Maybe ConfigLeaf
forall a. Maybe a
Nothing
adjustConfigTrie (Text
a:[Text]
as) Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f (Just (ConfigTrie Maybe ConfigLeaf
x ConfigMap
m)) = ConfigTrie -> Maybe ConfigTrie
forall a. a -> Maybe a
Just (ConfigTrie -> Maybe ConfigTrie)
-> (ConfigMap -> ConfigTrie) -> ConfigMap -> Maybe ConfigTrie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie Maybe ConfigLeaf
x (ConfigMap -> Maybe ConfigTrie)
-> t ConfigMap -> t (Maybe ConfigTrie)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
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 (Maybe ConfigLeaf -> Maybe ConfigTrie)
-> t (Maybe ConfigLeaf) -> t (Maybe ConfigTrie)
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 | ConfigMap -> Bool
forall k a. Map k a -> Bool
Map.null ConfigMap
m = Maybe ConfigTrie
forall a. Maybe a
Nothing
        g Maybe ConfigLeaf
x' = ConfigTrie -> Maybe ConfigTrie
forall a. a -> Maybe a
Just (Maybe ConfigLeaf -> ConfigMap -> ConfigTrie
ConfigTrie Maybe ConfigLeaf
x' ConfigMap
m)

-- | The given nonempty list of name segments (with the initial segment given as the first argument)
--   defines a lens into a @ConfigMap@.
adjustConfigMap :: Functor t => Text -> [Text] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> ConfigMap -> t ConfigMap
adjustConfigMap :: Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
a [Text]
as Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
f = (Maybe ConfigTrie -> t (Maybe ConfigTrie))
-> Text -> ConfigMap -> t ConfigMap
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 ([Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> Maybe ConfigTrie
-> t (Maybe ConfigTrie)
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

-- | Traverse an entire @ConfigMap@.  The first argument is
traverseConfigMap ::
  Applicative t =>
  [Text] {- ^ A REVERSED LIST of the name segments that represent the context from the root to the current @ConfigMap@. -} ->
  ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ An action to apply to each leaf. The path to the leaf is provided. -} ->
  ConfigMap {- ^ ConfigMap to traverse -} ->
  t ConfigMap
traverseConfigMap :: [Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f = (Text -> ConfigTrie -> t ConfigTrie) -> ConfigMap -> t ConfigMap
forall (t :: Type -> Type) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (\Text
k -> [Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigTrie
-> t ConfigTrie
forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigTrie
-> t ConfigTrie
traverseConfigTrie (Text
kText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
revPath) [Text] -> ConfigLeaf -> t ConfigLeaf
f)

-- | Traverse an entire @ConfigTrie@.
traverseConfigTrie ::
  Applicative t =>
  [Text] {- ^ A REVERSED LIST of the name segments that represent the context from the root to the current @ConfigTrie@. -} ->
  ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ An action to apply to each leaf. The path to the leaf is provided. -} ->
  ConfigTrie {- ^ @ConfigTrie@ to traverse -} ->
  t ConfigTrie
traverseConfigTrie :: [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 (Maybe ConfigLeaf -> ConfigMap -> ConfigTrie)
-> t (Maybe ConfigLeaf) -> t (ConfigMap -> ConfigTrie)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConfigLeaf -> t ConfigLeaf)
-> Maybe ConfigLeaf -> t (Maybe ConfigLeaf)
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 ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
revPath)) Maybe ConfigLeaf
x t (ConfigMap -> ConfigTrie) -> t ConfigMap -> t ConfigTrie
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
forall (t :: Type -> Type).
Applicative t =>
[Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
traverseConfigMap [Text]
revPath [Text] -> ConfigLeaf -> t ConfigLeaf
f ConfigMap
m

-- | Traverse a subtree of a @ConfigMap@.  If an empty path is provided, the entire @ConfigMap@ will
--   be traversed.
traverseSubtree ::
  Applicative t =>
  [Text] {- ^ Path indicating the subtree to traverse -} ->
  ([Text] -> ConfigLeaf -> t ConfigLeaf) {- ^ Action to apply to each leaf in the indicated subtree.  The path to the leaf is provided. -} ->
  ConfigMap {- ^ @ConfigMap@ to traverse -} ->
  t ConfigMap
traverseSubtree :: [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 = [Text]
-> ([Text] -> ConfigLeaf -> t ConfigLeaf)
-> ConfigMap
-> t ConfigMap
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 = (Maybe ConfigTrie -> t (Maybe ConfigTrie))
-> Text -> ConfigMap -> t ConfigMap
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 ((ConfigTrie -> t ConfigTrie)
-> Maybe ConfigTrie -> t (Maybe ConfigTrie)
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 Maybe ConfigLeaf
x (ConfigMap -> ConfigTrie) -> t ConfigMap -> t ConfigTrie
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> [Text] -> ConfigMap -> t ConfigMap
go [Text]
ps (Text
pText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
revPath) ConfigMap
m


-- | Add an option to the given @ConfigMap@.
insertOption :: (MonadIO m, MonadFail m) => ConfigDesc -> ConfigMap -> m ConfigMap
insertOption :: ConfigDesc -> ConfigMap -> m ConfigMap
insertOption (ConfigDesc (ConfigOption BaseTypeRepr tp
_tp (Text
p:|[Text]
ps)) OptionStyle tp
sty Maybe (Doc Void)
h) ConfigMap
m = Text
-> [Text]
-> (Maybe ConfigLeaf -> m (Maybe ConfigLeaf))
-> ConfigMap
-> m ConfigMap
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  =
       do MVar (Maybe (ConcreteVal tp))
ref <- IO (MVar (Maybe (ConcreteVal tp)))
-> m (MVar (Maybe (ConcreteVal tp)))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Maybe (ConcreteVal tp) -> IO (MVar (Maybe (ConcreteVal tp)))
forall a. a -> IO (MVar a)
newMVar (OptionStyle tp -> Maybe (ConcreteVal tp)
forall (tp :: BaseType). OptionStyle tp -> Maybe (ConcreteVal tp)
opt_default_value OptionStyle tp
sty))
          Maybe ConfigLeaf -> m (Maybe ConfigLeaf)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ConfigLeaf -> Maybe ConfigLeaf
forall a. a -> Maybe a
Just (OptionStyle tp
-> MVar (Maybe (ConcreteVal tp)) -> Maybe (Doc Void) -> ConfigLeaf
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))
  f (Just ConfigLeaf
_) = String -> m (Maybe ConfigLeaf)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
showPath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" already exists")

  showPath :: String
showPath = Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
"." (Text
pText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ps))


------------------------------------------------------------------------
-- Config

-- | The main configuration datatype.  It consists of an MVar
--   containing the actual configuration data.
newtype Config = Config (MVar ConfigMap)

-- | Construct a new configuration from the given configuration
--   descriptions.
initialConfig :: Integer           -- ^ Initial value for the `verbosity` option
              -> [ConfigDesc]      -- ^ Option descriptions to install
              -> IO (Config)
initialConfig :: Integer -> [ConfigDesc] -> IO Config
initialConfig Integer
initVerbosity [ConfigDesc]
ts = do
   Config
cfg <- MVar ConfigMap -> Config
Config (MVar ConfigMap -> Config) -> IO (MVar ConfigMap) -> IO Config
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigMap -> IO (MVar ConfigMap)
forall a. a -> IO (MVar a)
newMVar ConfigMap
forall k a. Map k a
Map.empty
   [ConfigDesc] -> Config -> IO ()
extendConfig (Integer -> [ConfigDesc]
builtInOpts Integer
initVerbosity [ConfigDesc] -> [ConfigDesc] -> [ConfigDesc]
forall a. [a] -> [a] -> [a]
++ [ConfigDesc]
ts) Config
cfg
   Config -> IO Config
forall (m :: Type -> Type) a. Monad m => a -> m a
return Config
cfg

-- | Extend an existing configuration with new options.  An error will be
--   raised if any of the given options clash with options that already exists.
extendConfig :: [ConfigDesc]
             -> Config
             -> IO ()
extendConfig :: [ConfigDesc] -> Config -> IO ()
extendConfig [ConfigDesc]
ts (Config MVar ConfigMap
cfg) =
  MVar ConfigMap -> (ConfigMap -> IO ConfigMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ConfigMap
cfg (\ConfigMap
m -> (ConfigMap -> ConfigDesc -> IO ConfigMap)
-> ConfigMap -> [ConfigDesc] -> IO ConfigMap
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((ConfigDesc -> ConfigMap -> IO ConfigMap)
-> ConfigMap -> ConfigDesc -> IO ConfigMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConfigDesc -> ConfigMap -> IO ConfigMap
forall (m :: Type -> Type).
(MonadIO m, MonadFail m) =>
ConfigDesc -> ConfigMap -> m ConfigMap
insertOption) ConfigMap
m [ConfigDesc]
ts)

-- | Verbosity of the simulator.  This option controls how much
--   informational and debugging output is generated.
--   0 yields low information output; 5 is extremely chatty.
verbosity :: ConfigOption BaseIntegerType
verbosity :: ConfigOption BaseIntegerType
verbosity = BaseTypeRepr BaseIntegerType
-> String -> ConfigOption BaseIntegerType
forall (tp :: BaseType).
BaseTypeRepr tp -> String -> ConfigOption tp
configOption BaseTypeRepr BaseIntegerType
BaseIntegerRepr String
"verbosity"

-- | Built-in options that are installed in every @Config@ object.
builtInOpts :: Integer -> [ConfigDesc]
builtInOpts :: Integer -> [ConfigDesc]
builtInOpts Integer
initialVerbosity =
  [ ConfigOption BaseIntegerType
-> ConcreteVal BaseIntegerType -> Text -> ConfigDesc
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)
  ]

-- | Return an operation that will consult the current value of the
--   verbosity option, and will print a string to the given @Handle@
--   if the provided int is smaller than the current verbosity setting.
verbosityLogger :: Config -> Handle -> IO (Int -> String -> IO ())
verbosityLogger :: Config -> Handle -> IO (Int -> String -> IO ())
verbosityLogger Config
cfg Handle
h =
  do OptionSetting BaseIntegerType
verb <- ConfigOption BaseIntegerType
-> Config -> IO (OptionSetting BaseIntegerType)
forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
getOptionSetting ConfigOption BaseIntegerType
verbosity Config
cfg
     (Int -> String -> IO ()) -> IO (Int -> String -> IO ())
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Int -> String -> IO ()) -> IO (Int -> String -> IO ()))
-> (Int -> String -> IO ()) -> IO (Int -> String -> IO ())
forall a b. (a -> b) -> a -> b
$ \Int
n String
msg ->
       do Integer
v <- OptionSetting BaseIntegerType -> IO Integer
forall (tp :: BaseType) a. Opt tp a => OptionSetting tp -> IO a
getOpt OptionSetting BaseIntegerType
verb
          Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
v) (Handle -> String -> IO ()
hPutStr Handle
h String
msg)

-- | A utility class for making working with option settings
--   easier.  The @tp@ argument is a @BaseType@, and the @a@
--   argument is an associcated Haskell type.
class Opt (tp :: BaseType) (a :: Type) | tp -> a where
  -- | Return the current value of the option, as a @Maybe@ value.
  getMaybeOpt :: OptionSetting tp -> IO (Maybe a)

  -- | Attempt to set the value of an option.  Return any errors
  --   or warnings.
  trySetOpt :: OptionSetting tp -> a -> IO OptionSetResult

  -- | Set the value of an option.  Return any generated warnings.
  --   Throw an exception if a validation error occurs.
  setOpt :: OptionSetting tp -> a -> IO [Doc Void]
  setOpt OptionSetting tp
x a
v = OptionSetting tp -> a -> IO OptionSetResult
forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> a -> IO OptionSetResult
trySetOpt OptionSetting tp
x a
v IO OptionSetResult
-> (OptionSetResult -> IO [Doc Void]) -> IO [Doc Void]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= OptionSetResult -> IO [Doc Void]
checkOptSetResult

  -- | Get the current value of an option.  Throw an exception
  --   if the option is not currently set.
  getOpt :: OptionSetting tp -> IO a
  getOpt OptionSetting tp
x = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
msg) a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe a -> IO a) -> IO (Maybe a) -> IO a
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< OptionSetting tp -> IO (Maybe a)
forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
getMaybeOpt OptionSetting tp
x
    where msg :: String
msg = String
"Option is not set: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigOption tp -> String
forall a. Show a => a -> String
show (OptionSetting tp -> ConfigOption tp
forall (tp :: BaseType). OptionSetting tp -> ConfigOption tp
optionSettingName OptionSetting tp
x)

-- | Throw an exception if the given @OptionSetResult@ indidcates
--   an error.  Otherwise, return any generated warnings.
checkOptSetResult :: OptionSetResult -> IO [Doc Void]
checkOptSetResult :: OptionSetResult -> IO [Doc Void]
checkOptSetResult OptionSetResult
res =
  case OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res of
    Just Doc Void
msg -> String -> IO [Doc Void]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (Doc Void -> String
forall a. Show a => a -> String
show Doc Void
msg)
    Maybe (Doc Void)
Nothing -> [Doc Void] -> IO [Doc Void]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Seq (Doc Void) -> [Doc Void]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (OptionSetResult -> Seq (Doc Void)
optionSetWarnings OptionSetResult
res))

instance Opt (BaseStringType Unicode) Text where
  getMaybeOpt :: OptionSetting (BaseStringType Unicode) -> IO (Maybe Text)
getMaybeOpt OptionSetting (BaseStringType Unicode)
x = (ConcreteVal (BaseStringType Unicode) -> Text)
-> Maybe (ConcreteVal (BaseStringType Unicode)) -> Maybe Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (StringLiteral Unicode -> Text
fromUnicodeLit (StringLiteral Unicode -> Text)
-> (ConcreteVal (BaseStringType Unicode) -> StringLiteral Unicode)
-> ConcreteVal (BaseStringType Unicode)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcreteVal (BaseStringType Unicode) -> StringLiteral Unicode
forall (si :: StringInfo).
ConcreteVal (BaseStringType si) -> StringLiteral si
fromConcreteString) (Maybe (ConcreteVal (BaseStringType Unicode)) -> Maybe Text)
-> IO (Maybe (ConcreteVal (BaseStringType Unicode)))
-> IO (Maybe Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSetting (BaseStringType Unicode)
-> IO (Maybe (ConcreteVal (BaseStringType Unicode)))
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 = OptionSetting (BaseStringType Unicode)
-> ConcreteVal (BaseStringType Unicode) -> IO OptionSetResult
forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting (BaseStringType Unicode)
x (StringLiteral Unicode -> ConcreteVal (BaseStringType Unicode)
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 = (ConcreteVal BaseIntegerType -> Integer)
-> Maybe (ConcreteVal BaseIntegerType) -> Maybe Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteVal BaseIntegerType -> Integer
fromConcreteInteger (Maybe (ConcreteVal BaseIntegerType) -> Maybe Integer)
-> IO (Maybe (ConcreteVal BaseIntegerType)) -> IO (Maybe Integer)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSetting BaseIntegerType
-> IO (Maybe (ConcreteVal BaseIntegerType))
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 = OptionSetting BaseIntegerType
-> ConcreteVal BaseIntegerType -> IO OptionSetResult
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 = (ConcreteVal BaseBoolType -> Bool)
-> Maybe (ConcreteVal BaseBoolType) -> Maybe Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcreteVal BaseBoolType -> Bool
fromConcreteBool (Maybe (ConcreteVal BaseBoolType) -> Maybe Bool)
-> IO (Maybe (ConcreteVal BaseBoolType)) -> IO (Maybe Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSetting BaseBoolType -> IO (Maybe (ConcreteVal BaseBoolType))
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 = OptionSetting BaseBoolType
-> ConcreteVal BaseBoolType -> IO OptionSetResult
forall (tp :: BaseType).
OptionSetting tp -> ConcreteVal tp -> IO OptionSetResult
setOption OptionSetting BaseBoolType
x (Bool -> ConcreteVal BaseBoolType
ConcreteBool Bool
v)

-- | Given a @ConfigOption@ name, produce an @OptionSetting@
--   object for accessing and setting the value of that option.
--
--   An exception is thrown if the named option cannot be found
--   the @Config@ object, or if a type mismatch occurs.
getOptionSetting ::
  ConfigOption tp ->
  Config ->
  IO (OptionSetting tp)
getOptionSetting :: ConfigOption tp -> Config -> IO (OptionSetting tp)
getOptionSetting o :: ConfigOption tp
o@(ConfigOption BaseTypeRepr tp
tp (Text
p:|[Text]
ps)) (Config MVar ConfigMap
cfg) =
   MVar ConfigMap -> IO ConfigMap
forall a. MVar a -> IO a
readMVar MVar ConfigMap
cfg IO ConfigMap
-> (ConfigMap -> IO (OptionSetting tp)) -> IO (OptionSetting tp)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Const (IO (OptionSetting tp)) ConfigMap -> IO (OptionSetting tp)
forall a k (b :: k). Const a b -> a
getConst (Const (IO (OptionSetting tp)) ConfigMap -> IO (OptionSetting tp))
-> (ConfigMap -> Const (IO (OptionSetting tp)) ConfigMap)
-> ConfigMap
-> IO (OptionSetting tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> [Text]
-> (Maybe ConfigLeaf
    -> Const (IO (OptionSetting tp)) (Maybe ConfigLeaf))
-> ConfigMap
-> Const (IO (OptionSetting tp)) ConfigMap
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  = IO (OptionSetting tp)
-> Const (IO (OptionSetting tp)) (Maybe ConfigLeaf)
forall k a (b :: k). a -> Const a b
Const (String -> IO (OptionSetting tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO (OptionSetting tp))
-> String -> IO (OptionSetting tp)
forall a b. (a -> b) -> a -> b
$ String
"Option not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigOption tp -> String
forall a. Show a => a -> String
show ConfigOption tp
o)
  f (Just ConfigLeaf
x) = IO (OptionSetting tp)
-> Const (IO (OptionSetting tp)) (Maybe ConfigLeaf)
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 <- BaseTypeRepr tp -> BaseTypeRepr tp -> Maybe (tp :~: tp)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (OptionStyle tp -> BaseTypeRepr tp
forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) BaseTypeRepr tp
tp = OptionSetting tp -> IO (OptionSetting tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (OptionSetting tp -> IO (OptionSetting tp))
-> OptionSetting tp -> IO (OptionSetting tp)
forall a b. (a -> b) -> a -> b
$
      OptionSetting :: forall (tp :: BaseType).
ConfigOption tp
-> IO (Maybe (ConcreteVal tp))
-> (ConcreteVal tp -> IO OptionSetResult)
-> OptionSetting tp
OptionSetting
      { optionSettingName :: ConfigOption tp
optionSettingName = ConfigOption tp
o
      , getOption :: IO (Maybe (ConcreteVal tp))
getOption  = MVar (Maybe (ConcreteVal tp)) -> IO (Maybe (ConcreteVal tp))
forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
      , setOption :: ConcreteVal tp -> IO OptionSetResult
setOption = \ConcreteVal tp
v -> MVar (Maybe (ConcreteVal tp))
-> (Maybe (ConcreteVal tp)
    -> IO (Maybe (ConcreteVal tp), OptionSetResult))
-> IO OptionSetResult
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (ConcreteVal tp))
ref ((Maybe (ConcreteVal tp)
  -> IO (Maybe (ConcreteVal tp), OptionSetResult))
 -> IO OptionSetResult)
-> (Maybe (ConcreteVal tp)
    -> IO (Maybe (ConcreteVal tp), OptionSetResult))
-> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ \Maybe (ConcreteVal tp)
old ->
          do OptionSetResult
res <- OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
forall (tp :: BaseType).
OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
opt_onset OptionStyle tp
sty Maybe (ConcreteVal tp)
old ConcreteVal tp
ConcreteVal tp
v
             let new :: Maybe (ConcreteVal tp)
new = if (Maybe (Doc Void) -> Bool
forall a. Maybe a -> Bool
isJust (OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res)) then Maybe (ConcreteVal tp)
old else (ConcreteVal tp -> Maybe (ConcreteVal tp)
forall a. a -> Maybe a
Just ConcreteVal tp
v)
             Maybe (ConcreteVal tp)
new Maybe (ConcreteVal tp)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
`seq` (Maybe (ConcreteVal tp), OptionSetResult)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (ConcreteVal tp)
new, OptionSetResult
res)
      }
    | Bool
otherwise = String -> IO (OptionSetting tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Type mismatch retrieving option " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigOption tp -> String
forall a. Show a => a -> String
show ConfigOption tp
o String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
"\nExpected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseTypeRepr tp -> String
forall a. Show a => a -> String
show BaseTypeRepr tp
tp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseTypeRepr tp -> String
forall a. Show a => a -> String
show (OptionStyle tp -> BaseTypeRepr tp
forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty))

-- | Given a text name, produce an @OptionSetting@
--   object for accessing and setting the value of that option.
--
--   An exception is thrown if the named option cannot be found.
getOptionSettingFromText ::
  Text ->
  Config ->
  IO (Some OptionSetting)
getOptionSettingFromText :: Text -> Config -> IO (Some OptionSetting)
getOptionSettingFromText Text
nm (Config MVar ConfigMap
cfg) =
   case Text -> Maybe (NonEmpty Text)
splitPath Text
nm of
     Maybe (NonEmpty Text)
Nothing -> String -> IO (Some OptionSetting)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Illegal empty name for option"
     Just (Text
p:|[Text]
ps) -> MVar ConfigMap -> IO ConfigMap
forall a. MVar a -> IO a
readMVar MVar ConfigMap
cfg IO ConfigMap
-> (ConfigMap -> IO (Some OptionSetting))
-> IO (Some OptionSetting)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Const (IO (Some OptionSetting)) ConfigMap
-> IO (Some OptionSetting)
forall a k (b :: k). Const a b -> a
getConst (Const (IO (Some OptionSetting)) ConfigMap
 -> IO (Some OptionSetting))
-> (ConfigMap -> Const (IO (Some OptionSetting)) ConfigMap)
-> ConfigMap
-> IO (Some OptionSetting)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> [Text]
-> (Maybe ConfigLeaf
    -> Const (IO (Some OptionSetting)) (Maybe ConfigLeaf))
-> ConfigMap
-> Const (IO (Some OptionSetting)) ConfigMap
forall (t :: Type -> Type).
Functor t =>
Text
-> [Text]
-> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf))
-> ConfigMap
-> t ConfigMap
adjustConfigMap Text
p [Text]
ps (NonEmpty Text
-> Maybe ConfigLeaf
-> Const (IO (Some OptionSetting)) (Maybe ConfigLeaf)
forall k (m :: Type -> Type) (b :: k).
MonadFail m =>
NonEmpty Text
-> Maybe ConfigLeaf -> Const (m (Some OptionSetting)) b
f (Text
pText -> [Text] -> NonEmpty Text
forall 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  = m (Some OptionSetting) -> Const (m (Some OptionSetting)) b
forall k a (b :: k). a -> Const a b
Const (String -> m (Some OptionSetting)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m (Some OptionSetting))
-> String -> m (Some OptionSetting)
forall a b. (a -> b) -> a -> b
$ String
"Option not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
"." (Text
pText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ps))))
  f NonEmpty Text
path (Just ConfigLeaf
x) = m (Some OptionSetting) -> Const (m (Some OptionSetting)) b
forall k a (b :: k). a -> Const a b
Const (NonEmpty Text -> ConfigLeaf -> m (Some OptionSetting)
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) = Some OptionSetting -> m (Some OptionSetting)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Some OptionSetting -> m (Some OptionSetting))
-> Some OptionSetting -> m (Some OptionSetting)
forall a b. (a -> b) -> a -> b
$
    OptionSetting tp -> Some OptionSetting
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some OptionSetting :: forall (tp :: BaseType).
ConfigOption tp
-> IO (Maybe (ConcreteVal tp))
-> (ConcreteVal tp -> IO OptionSetResult)
-> OptionSetting tp
OptionSetting
         { optionSettingName :: ConfigOption tp
optionSettingName = BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption (OptionStyle tp -> BaseTypeRepr tp
forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) NonEmpty Text
path
         , getOption :: IO (Maybe (ConcreteVal tp))
getOption = MVar (Maybe (ConcreteVal tp)) -> IO (Maybe (ConcreteVal tp))
forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
         , setOption :: ConcreteVal tp -> IO OptionSetResult
setOption = \ConcreteVal tp
v -> MVar (Maybe (ConcreteVal tp))
-> (Maybe (ConcreteVal tp)
    -> IO (Maybe (ConcreteVal tp), OptionSetResult))
-> IO OptionSetResult
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe (ConcreteVal tp))
ref ((Maybe (ConcreteVal tp)
  -> IO (Maybe (ConcreteVal tp), OptionSetResult))
 -> IO OptionSetResult)
-> (Maybe (ConcreteVal tp)
    -> IO (Maybe (ConcreteVal tp), OptionSetResult))
-> IO OptionSetResult
forall a b. (a -> b) -> a -> b
$ \Maybe (ConcreteVal tp)
old ->
             do OptionSetResult
res <- OptionStyle tp
-> Maybe (ConcreteVal tp) -> ConcreteVal tp -> IO OptionSetResult
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 (Maybe (Doc Void) -> Bool
forall a. Maybe a -> Bool
isJust (OptionSetResult -> Maybe (Doc Void)
optionSetError OptionSetResult
res)) then Maybe (ConcreteVal tp)
old else (ConcreteVal tp -> Maybe (ConcreteVal tp)
forall a. a -> Maybe a
Just ConcreteVal tp
v)
                Maybe (ConcreteVal tp)
new Maybe (ConcreteVal tp)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
`seq` (Maybe (ConcreteVal tp), OptionSetResult)
-> IO (Maybe (ConcreteVal tp), OptionSetResult)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (ConcreteVal tp)
new, OptionSetResult
res)
         }


-- | A @ConfigValue@ bundles together the name of an option with its current value.
data ConfigValue where
  ConfigValue :: ConfigOption tp -> ConcreteVal tp -> ConfigValue

-- | Given the name of a subtree, return all
--   the currently-set configurtion values in that subtree.
--
--   If the subtree name is empty, the entire tree will be traversed.
getConfigValues ::
  Text ->
  Config ->
  IO [ConfigValue]
getConfigValues :: Text -> Config -> IO [ConfigValue]
getConfigValues Text
prefix (Config MVar ConfigMap
cfg) =
  do ConfigMap
m <- MVar ConfigMap -> IO ConfigMap
forall a. MVar a -> IO a
readMVar MVar ConfigMap
cfg
     let ps :: [Text]
ps = 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
_ = String -> WriterT (Seq ConfigValue) IO ConfigLeaf
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> WriterT (Seq ConfigValue) IO ConfigLeaf)
-> String -> WriterT (Seq ConfigValue) IO ConfigLeaf
forall a b. (a -> b) -> a -> b
$ String
"getConfigValues: illegal empty option name"
         f (Text
p:[Text]
path) l :: ConfigLeaf
l@(ConfigLeaf OptionStyle tp
sty MVar (Maybe (ConcreteVal tp))
ref Maybe (Doc Void)
_h) =
            do IO (Maybe (ConcreteVal tp))
-> WriterT (Seq ConfigValue) IO (Maybe (ConcreteVal tp))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (MVar (Maybe (ConcreteVal tp)) -> IO (Maybe (ConcreteVal tp))
forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref) WriterT (Seq ConfigValue) IO (Maybe (ConcreteVal tp))
-> (Maybe (ConcreteVal tp) -> WriterT (Seq ConfigValue) IO ())
-> WriterT (Seq ConfigValue) IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                 Just ConcreteVal tp
x  -> Seq ConfigValue -> WriterT (Seq ConfigValue) IO ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (ConfigValue -> Seq ConfigValue
forall a. a -> Seq a
Seq.singleton (ConfigOption tp -> ConcreteVal tp -> ConfigValue
forall (tp :: BaseType).
ConfigOption tp -> ConcreteVal tp -> ConfigValue
ConfigValue (BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
forall (tp :: BaseType).
BaseTypeRepr tp -> NonEmpty Text -> ConfigOption tp
ConfigOption (OptionStyle tp -> BaseTypeRepr tp
forall (tp :: BaseType). OptionStyle tp -> BaseTypeRepr tp
opt_type OptionStyle tp
sty) (Text
pText -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:|[Text]
path)) ConcreteVal tp
x))
                 Maybe (ConcreteVal tp)
Nothing -> () -> WriterT (Seq ConfigValue) IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
               ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf
forall (m :: Type -> Type) a. Monad m => a -> m a
return ConfigLeaf
l
     Seq ConfigValue -> [ConfigValue]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (Seq ConfigValue -> [ConfigValue])
-> IO (Seq ConfigValue) -> IO [ConfigValue]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Seq ConfigValue) IO ConfigMap -> IO (Seq ConfigValue)
forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT ([Text]
-> ([Text]
    -> ConfigLeaf -> WriterT (Seq ConfigValue) IO ConfigLeaf)
-> ConfigMap
-> WriterT (Seq ConfigValue) IO ConfigMap
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 :: [Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting [Text]
nm Maybe (ConcreteVal tp)
v = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fill Int
30 (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
nm)
                           Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
-> (ConcreteVal tp -> Doc ann) -> Maybe (ConcreteVal tp) -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall a. Monoid a => a
mempty (\ConcreteVal tp
x -> Doc ann
" = " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ConcreteVal tp -> Doc ann
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 :: [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 =
  [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
vcat
  [ Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
group (Doc Void -> Doc Void) -> Doc Void -> Doc Void
forall a b. (a -> b) -> a -> b
$ [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
fillCat [[Text] -> Maybe (ConcreteVal tp) -> Doc Void
forall (tp :: BaseType) ann.
[Text] -> Maybe (ConcreteVal tp) -> Doc ann
ppSetting [Text]
nm Maybe (ConcreteVal tp)
x, Int -> Doc Void -> Doc Void
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (OptionStyle tp -> Doc Void
forall (tp :: BaseType). OptionStyle tp -> Doc Void
opt_help OptionStyle tp
sty)]
  , Doc Void -> (Doc Void -> Doc Void) -> Maybe (Doc Void) -> Doc Void
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Void
forall a. Monoid a => a
mempty (Int -> Doc Void -> Doc Void
forall ann. Int -> Doc ann -> Doc ann
indent Int
2) 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 <- MVar (Maybe (ConcreteVal tp)) -> IO (Maybe (ConcreteVal tp))
forall a. MVar a -> IO a
readMVar MVar (Maybe (ConcreteVal tp))
ref
     Doc Void -> IO (Doc Void)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Doc Void -> IO (Doc Void)) -> Doc Void -> IO (Doc Void)
forall a b. (a -> b) -> a -> b
$ [Text]
-> OptionStyle tp
-> Maybe (ConcreteVal tp)
-> Maybe (Doc Void)
-> Doc Void
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

-- | Given the name of a subtree, compute help text for
--   all the options avaliable in that subtree.
--
--   If the subtree name is empty, the entire tree will be traversed.
configHelp ::
  Text ->
  Config ->
  IO [Doc Void]
configHelp :: Text -> Config -> IO [Doc Void]
configHelp Text
prefix (Config MVar ConfigMap
cfg) =
  do ConfigMap
m <- MVar ConfigMap -> IO ConfigMap
forall a. MVar a -> IO a
readMVar MVar ConfigMap
cfg
     let ps :: [Text]
ps = 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 <- IO (Doc Void) -> WriterT (Seq (Doc Void)) IO (Doc Void)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ([Text] -> ConfigLeaf -> IO (Doc Void)
ppConfigLeaf [Text]
nm ConfigLeaf
leaf)
                        Seq (Doc Void) -> WriterT (Seq (Doc Void)) IO ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (Doc Void -> Seq (Doc Void)
forall a. a -> Seq a
Seq.singleton Doc Void
d)
                        ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf
forall (m :: Type -> Type) a. Monad m => a -> m a
return ConfigLeaf
leaf
     Seq (Doc Void) -> [Doc Void]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (Seq (Doc Void) -> [Doc Void])
-> IO (Seq (Doc Void)) -> IO [Doc Void]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterT (Seq (Doc Void)) IO ConfigMap -> IO (Seq (Doc Void))
forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT ([Text]
-> ([Text] -> ConfigLeaf -> WriterT (Seq (Doc Void)) IO ConfigLeaf)
-> ConfigMap
-> WriterT (Seq (Doc Void)) IO ConfigMap
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 :: Rational -> Doc ann
prettyRational = Rational -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow