diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for config-schema -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0.0 -- 2017-05-07 + +* Expose `liftValueSpec` and `liftSectionSpec` +* Add `fractionalSpec` +* Add `nonemptySpec` and `oneOrNonemptySpec` +* `loadValue` returns a `NonEmpty LoadError` + +## 0.1.0.0 -- 2017-05-06 * First version. Released on an unsuspecting world. diff --git a/config-schema.cabal b/config-schema.cabal --- a/config-schema.cabal +++ b/config-schema.cabal @@ -1,5 +1,5 @@ name: config-schema -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Schema definitions for the config-value package description: This package makes it possible to defined schemas for use when loading configuration files using the config-value format. diff --git a/src/Config/Schema.hs b/src/Config/Schema.hs --- a/src/Config/Schema.hs +++ b/src/Config/Schema.hs @@ -9,6 +9,10 @@ These schemas can be used to generate a validating configuration file loader, and to produce documentation about the supported format. +For documentation on the + file format, see the + module. + "Config.Schema.Spec" provides definitions used to make new schemas. "Config.Schema.Load" uses schemas to match schemas against configuration values. diff --git a/src/Config/Schema/Load.hs b/src/Config/Schema/Load.hs --- a/src/Config/Schema/Load.hs +++ b/src/Config/Schema/Load.hs @@ -18,15 +18,16 @@ , Problem(..) ) where -import Control.Applicative (Alternative, optional) -import Control.Monad (MonadPlus, unless, zipWithM) +import Control.Monad (unless, zipWithM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), runStateT) -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader -import Data.Foldable (asum) +import Control.Monad.Trans.Except (Except, runExcept, throwE) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local) +import Data.Functor.Alt (Alt(())) import Data.Monoid ((<>)) import Data.Ratio (numerator, denominator) +import Data.Semigroup.Foldable (asum1) +import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import qualified Data.Text as Text @@ -38,9 +39,9 @@ -- the interpretation of that value or the list of errors -- encountered. loadValue :: - ValueSpecs a {- ^ specification -} -> - Value {- ^ value -} -> - Either [LoadError] a {- ^ error or decoded value -} + ValueSpecs a {- ^ specification -} -> + Value {- ^ value -} -> + Either (NonEmpty LoadError) a {- ^ errors or decoded value -} loadValue spec val = runLoad (getValue spec val) @@ -49,7 +50,7 @@ do v <- StateT (lookupSection k) lift (scope k (getValue w v)) getSection (OptSection k _ w) = - do mb <- optional (StateT (lookupSection k)) + do mb <- optional1 (StateT (lookupSection k)) lift (traverse (scope k . getValue w) mb) @@ -61,7 +62,7 @@ getValue :: ValueSpecs a -> Value -> Load a -getValue s v = asum (runValueSpecs (getValue1 v) s) +getValue s v = asum1 (runValueSpecs (getValue1 v) s) -- | Match a primitive value specification against a single value. @@ -80,7 +81,7 @@ getValue1 _ TextSpec = loadFail (SpecMismatch "text") getValue1 _ IntegerSpec = loadFail (SpecMismatch "integer") -getValue1 _ RationalSpec = loadFail (SpecMismatch "rational") +getValue1 _ RationalSpec = loadFail (SpecMismatch "number") getValue1 _ ListSpec{} = loadFail (SpecMismatch "list") getValue1 _ AnyAtomSpec = loadFail (SpecMismatch "atom") getValue1 _ (AtomSpec a) = loadFail (SpecMismatch ("`" <> a <> "`")) @@ -109,8 +110,8 @@ -- | Extract a section from a list of sections by name. lookupSection :: - Text {- ^ section name -} -> - [Section] {- ^ available sections -} -> + Text {- ^ section name -} -> + [Section] {- ^ available sections -} -> Load (Value, [Section]) {- ^ found value and remaining sections -} lookupSection key [] = loadFail (MissingSection key) lookupSection key (s@(Section k v):xs) @@ -140,9 +141,11 @@ -- | Type used to match values against specifiations. This type tracks -- the current nested fields (updated with scope) and can throw -- errors using loadFail. -newtype Load a = MkLoad { unLoad :: ReaderT [Text] (Except [LoadError]) a } - deriving (Functor, Applicative, Monad, Alternative, MonadPlus) +newtype Load a = MkLoad { unLoad :: ReaderT [Text] (Except (NonEmpty LoadError)) a } + deriving (Functor, Applicative, Monad) +instance Alt Load where MkLoad x MkLoad y = MkLoad (x y) + -- | Type for errors that can be encountered while decoding a value according -- to a specification. The error includes a key path indicating where in -- the configuration file the error occurred. @@ -152,7 +155,7 @@ -- | Run the Load computation until it produces a result or terminates -- with a list of errors. -runLoad :: Load a -> Either [LoadError] a +runLoad :: Load a -> Either (NonEmpty LoadError) a runLoad = runExcept . flip runReaderT [] . unLoad @@ -171,4 +174,11 @@ loadFail :: Problem -> Load a loadFail cause = MkLoad $ do path <- ask - lift (throwE [LoadError (reverse path) cause]) + lift (throwE (pure (LoadError (reverse path) cause))) + +------------------------------------------------------------------------ + +-- | One or none. This definition is different from the normal @optional@ definition +-- because it uses 'Alt'. This allows it to work on types that are not @Alternative@. +optional1 :: (Applicative f, Alt f) => f a -> f (Maybe a) +optional1 fa = Just <$> fa pure Nothing diff --git a/src/Config/Schema/Spec.hs b/src/Config/Schema/Spec.hs --- a/src/Config/Schema/Spec.hs +++ b/src/Config/Schema/Spec.hs @@ -1,5 +1,5 @@ {-# Language FlexibleInstances, RankNTypes, GADTs, KindSignatures #-} -{-# Language GeneralizedNewtypeDeriving #-} +{-# Language GeneralizedNewtypeDeriving, OverloadedStrings #-} {-| Module : Config.Schema.Spec @@ -40,9 +40,12 @@ -- * Derived specifications , oneOrList - , numSpec , yesOrNoSpec , stringSpec + , numSpec + , fractionalSpec + , nonemptySpec + , oneOrNonemptySpec -- * Executing specifications , runSections @@ -52,7 +55,9 @@ -- * Primitive specifications , SectionSpec(..) + , liftSectionSpec , ValueSpec(..) + , liftValueSpec ) where @@ -62,6 +67,7 @@ import Data.Functor.Compose (Compose(..), getCompose) import Data.Functor.Alt (Alt(..)) import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text @@ -91,14 +97,32 @@ -- | Lift a single specification into a list of specifications. -sectionSpec :: SectionSpec a -> SectionSpecs a -sectionSpec = MkSectionSpecs . liftAp +-- +-- @since 0.1.1.0 +liftSectionSpec :: SectionSpec a -> SectionSpecs a +liftSectionSpec = MkSectionSpecs . liftAp +-- | Given an function that handles a single, primitive section specification; +-- 'runSections' will generate one that processes a whole 'SectionsSpec'. +-- +-- The results from each section will be sequence together using the 'Applicative' +-- instance in of the result type, and the results can be indexed by the type +-- parameter of the specification. +-- +-- For an example use of 'runSections', see "Config.Schema.Load". runSections :: Applicative f => (forall x. SectionSpec x -> f x) -> SectionSpecs a -> f a runSections f (MkSectionSpecs s) = runAp f s +-- | Given an function that handles a single, primitive section specification; +-- 'runSections_' will generate one that processes a whole 'SectionsSpec'. +-- +-- The results from each section will be sequence together using the 'Monoid' +-- instance in of the result type, and the results will not be indexed by the +-- type parameter of the specifications. +-- +-- For an example use of 'runSections_', see "Config.Schema.Docs". runSections_ :: Monoid m => (forall x. SectionSpec x -> m) -> SectionSpecs a -> m runSections_ f (MkSectionSpecs s) = runAp_ f s @@ -114,7 +138,7 @@ Text {- ^ section name -} -> Text {- ^ description -} -> SectionSpecs a -reqSection n i = sectionSpec (ReqSection n i valuesSpec) +reqSection n i = liftSectionSpec (ReqSection n i valuesSpec) -- | Specification for a required section with an explicit value specification. @@ -123,7 +147,7 @@ Text {- ^ description -} -> ValueSpecs a {- ^ value specification -} -> SectionSpecs a -reqSection' n i w = sectionSpec (ReqSection n i w) +reqSection' n i w = liftSectionSpec (ReqSection n i w) -- | Specification for an optional section with an implicit value specification. @@ -132,7 +156,7 @@ Text {- ^ section name -} -> Text {- ^ description -} -> SectionSpecs (Maybe a) -optSection n i = sectionSpec (OptSection n i valuesSpec) +optSection n i = liftSectionSpec (OptSection n i valuesSpec) -- | Specification for an optional section with an explicit value specification. @@ -141,7 +165,7 @@ Text {- ^ description -} -> ValueSpecs a {- ^ value specification -} -> SectionSpecs (Maybe a) -optSection' n i w = sectionSpec (OptSection n i w) +optSection' n i w = liftSectionSpec (OptSection n i w) ------------------------------------------------------------------------ @@ -161,7 +185,7 @@ RationalSpec :: ValueSpec Rational -- | Matches any atom - AnyAtomSpec :: ValueSpec Text + AnyAtomSpec :: ValueSpec Text -- | Specific atom to be matched AtomSpec :: Text -> ValueSpec () @@ -182,6 +206,8 @@ -- | Non-empty disjunction of value specifications. This type is the primary -- way to specify expected values. Use the 'Spec' class to generate 'ValueSpecs' -- for simple types. +-- +-- Multiple specifications can be combined using this type's 'Alt' instance. newtype ValueSpecs a = MkValueSpecs { unValueSpecs :: Compose NonEmpty (Coyoneda ValueSpec) a } deriving Functor @@ -195,7 +221,7 @@ -- Unlike 'runValueSpecs_', this allows the result of the interpretation to be indexed -- by the type of the primitive value specifications. runValueSpecs :: Functor f => (forall x. ValueSpec x -> f x) -> ValueSpecs a -> NonEmpty (f a) -runValueSpecs f = fmap (lowerCoyoneda . hoistCoyoneda f) . getCompose . unValueSpecs +runValueSpecs f = fmap (lowerCoyoneda . hoistCoyoneda f) . getCompose . unValueSpecs -- | Given an interpretation of a primitive value specification, extract a list of @@ -205,8 +231,10 @@ -- | Lift a primitive value specification to 'ValueSpecs'. -valueSpec :: ValueSpec a -> ValueSpecs a -valueSpec = MkValueSpecs . Compose . pure . liftCoyoneda +-- +-- @since 0.1.1.0 +liftValueSpec :: ValueSpec a -> ValueSpecs a +liftValueSpec = MkValueSpecs . Compose . pure . liftCoyoneda ------------------------------------------------------------------------ @@ -216,22 +244,22 @@ -- | Class of value specifications that don't require arguments. class Spec a where valuesSpec :: ValueSpecs a -instance Spec Text where valuesSpec = valueSpec TextSpec -instance Spec Integer where valuesSpec = valueSpec IntegerSpec -instance Spec Rational where valuesSpec = valueSpec RationalSpec +instance Spec Text where valuesSpec = liftValueSpec TextSpec +instance Spec Integer where valuesSpec = liftValueSpec IntegerSpec +instance Spec Rational where valuesSpec = liftValueSpec RationalSpec instance Spec Int where valuesSpec = fromInteger <$> valuesSpec -instance Spec a => Spec [a] where valuesSpec = valueSpec (ListSpec valuesSpec) +instance Spec a => Spec [a] where valuesSpec = liftValueSpec (ListSpec valuesSpec) instance (Spec a, Spec b) => Spec (Either a b) where valuesSpec = Left <$> valuesSpec Right <$> valuesSpec -- | Specification for matching a particular atom. atomSpec :: Text -> ValueSpecs () -atomSpec = valueSpec . AtomSpec +atomSpec = liftValueSpec . AtomSpec -- | Specification for matching any atom. Matched atom is returned. anyAtomSpec :: ValueSpecs Text -anyAtomSpec = valueSpec AnyAtomSpec +anyAtomSpec = liftValueSpec AnyAtomSpec -- | Specification for matching any text as a 'String' stringSpec :: ValueSpecs String @@ -241,10 +269,16 @@ numSpec :: Num a => ValueSpecs a numSpec = fromInteger <$> valuesSpec +-- | Specification for matching any fractional number. +-- +-- @since 0.1.1.0 +fractionalSpec :: Fractional a => ValueSpecs a +fractionalSpec = fromRational <$> valuesSpec + -- | Specification for matching a list of values each satisfying a -- given element specification. listSpec :: ValueSpecs a -> ValueSpecs [a] -listSpec = valueSpec . ListSpec +listSpec = liftValueSpec . ListSpec -- | Named subsection value specification. The unique identifier will be used @@ -254,7 +288,7 @@ Text {- ^ unique documentation identifier -} -> SectionSpecs a {- ^ underlying specification -} -> ValueSpecs a -sectionsSpec i s = valueSpec (SectionSpecs i s) +sectionsSpec i s = liftValueSpec (SectionSpecs i s) -- | Named value specification. This is useful for factoring complicated @@ -264,7 +298,7 @@ Text {- ^ name -} -> ValueSpecs a {- ^ underlying specification -} -> ValueSpecs a -namedSpec n s = valueSpec (NamedSpec n s) +namedSpec n s = liftValueSpec (NamedSpec n s) -- | Specification that matches either a single element or multiple @@ -278,7 +312,7 @@ -- to validate the value extracted by a specification. If 'Nothing' -- is returned the value is considered to have failed validation. customSpec :: Text -> ValueSpecs a -> (a -> Maybe b) -> ValueSpecs b -customSpec lbl w f = valueSpec (CustomSpec lbl (f <$> w)) +customSpec lbl w f = liftValueSpec (CustomSpec lbl (f <$> w)) -- | Specification for using @yes@ and @no@ to represent booleans 'True' @@ -286,6 +320,19 @@ yesOrNoSpec :: ValueSpecs Bool yesOrNoSpec = True <$ atomSpec (Text.pack "yes") False <$ atomSpec (Text.pack "no") + + +-- | Matches a non-empty list. +-- +-- @since 0.1.1.0 +nonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a) +nonemptySpec s = customSpec "nonempty" (listSpec s) NonEmpty.nonEmpty + +-- | Matches a single element or a non-empty list. +-- +-- @since 0.1.1.0 +oneOrNonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a) +oneOrNonemptySpec s = pure <$> s nonemptySpec s ------------------------------------------------------------------------