diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for config-schema +## 1.2.0.0 + +* Update to build against `config-value-0.7.0.0` +* Added additional specs and instances to `Config.Schema.Spec` +* Primitive number spec now only matches `Number`, previous + `IntegerSpec` is now derived in terms of `NumberSpec` + ## 1.1.0.0 * Simplify field types of `ValueSpecMismatch` diff --git a/config-schema.cabal b/config-schema.cabal --- a/config-schema.cabal +++ b/config-schema.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: config-schema -version: 1.1.0.0 +version: 1.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. @@ -17,7 +17,7 @@ extra-source-files: ChangeLog.md README.md homepage: https://github.com/glguy/config-schema bug-reports: https://github.com/glguy/config-schema/issues -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 source-repository head type: git @@ -33,8 +33,8 @@ Config.Schema.Types build-depends: - base >=4.8 && <4.13, - config-value >=0.6 && <0.7, + base >=4.8 && <4.14, + config-value ^>=0.7, containers >=0.5 && <0.7, free >=4.12 && <5.2, kan-extensions >=5.0.2 && <5.3, diff --git a/src/Config/Schema/Docs.hs b/src/Config/Schema/Docs.hs --- a/src/Config/Schema/Docs.hs +++ b/src/Config/Schema/Docs.hs @@ -1,4 +1,4 @@ -{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-} +{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving, CPP #-} {-| Module : Config.Schema.Docs @@ -42,7 +42,6 @@ import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Map (Map) -import Data.Monoid (Monoid(..)) import qualified Data.Map as Map import qualified Data.Semigroup as S import Data.Text (Text) @@ -51,6 +50,10 @@ (Doc, fsep, text, (<>), ($+$), (<+>), nest, empty, hsep, parens) import Prelude hiding ((<>)) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid (Monoid(..)) +#endif + import Config.Schema.Spec import Config.Schema.Types @@ -126,8 +129,7 @@ valueDoc w = case w of TextSpec -> pure "text" - IntegerSpec -> pure "integer" - RationalSpec -> pure "number" + NumberSpec -> pure "number" AtomSpec a -> pure ("`" <> txt a <> "`") AnyAtomSpec -> pure "atom" SectionsSpec l s -> sectionsDoc l s 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 @@ -25,7 +25,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), runStateT, state) import Control.Monad.Trans.Except (Except, runExcept, throwE, withExcept) -import Data.Ratio (numerator, denominator) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) @@ -98,10 +97,7 @@ -- | Match a primitive value specification against a single value. getValue2 :: Value p -> PrimValueSpec a -> Except (Problem p) a getValue2 (Text _ t) TextSpec = pure t -getValue2 (Number _ _ n) IntegerSpec = pure n -getValue2 (Floating _ a b) IntegerSpec | Just i <- floatingToInteger a b = pure i -getValue2 (Number _ _ n) RationalSpec = pure (fromInteger n) -getValue2 (Floating _ a b) RationalSpec = pure (floatingToRational a b) +getValue2 (Number _ n) NumberSpec = pure n getValue2 (List _ xs) (ListSpec w) = getList w xs getValue2 (Atom _ b) AnyAtomSpec = pure (atomName b) getValue2 (Atom _ b) (AtomSpec a) @@ -146,17 +142,3 @@ | key == k = (Just v, xs) | otherwise = case lookupSection key xs of (res, xs') -> (res, s:xs') - ------------------------------------------------------------------------- - --- | Interpret a @config-value@ floating point number as a 'Rational'. -floatingToRational :: Integer -> Integer -> Rational -floatingToRational x y = fromInteger x * 10^^y - --- | Interpret a @config-value@ floating point number as an 'Integer' --- if possible. -floatingToInteger :: Integer -> Integer -> Maybe Integer -floatingToInteger x y - | denominator r == 1 = Just (numerator r) - | otherwise = Nothing - where r = floatingToRational x y diff --git a/src/Config/Schema/Load/Error.hs b/src/Config/Schema/Load/Error.hs --- a/src/Config/Schema/Load/Error.hs +++ b/src/Config/Schema/Load/Error.hs @@ -1,4 +1,4 @@ -{-# Language GADTs, OverloadedStrings #-} +{-# Language GADTs, OverloadedStrings, CPP #-} {-| Module : Config.Schema.Load.Error Description : Error types and rendering for Load module @@ -45,11 +45,14 @@ import Text.PrettyPrint (Doc, fsep, ($+$), nest, text, vcat, (<+>), empty, punctuate, comma, int, colon, hcat) -import Data.Monoid ((<>)) import Config import Config.Schema.Types +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + -- | Newtype wrapper for schema load errors. data ValueSpecMismatch p = -- | Problem value and list of specification failures @@ -80,8 +83,7 @@ -- | Describe outermost shape of a 'PrimValueSpec' describeSpec :: PrimValueSpec a -> Text describeSpec TextSpec = "text" -describeSpec IntegerSpec = "integer" -describeSpec RationalSpec = "number" +describeSpec NumberSpec = "number" describeSpec AnyAtomSpec = "atom" describeSpec (AtomSpec a) = "atom `" <> a <> "`" describeSpec (ListSpec _) = "list" @@ -93,8 +95,7 @@ -- | Describe outermost shape of a 'Value' describeValue :: Value p -> Text describeValue Text{} = "text" -describeValue Number{} = "integer" -describeValue Floating{} = "number" +describeValue Number{} = "number" describeValue (Atom _ a) = "atom `" <> atomName a <> "`" describeValue Sections{} = "sections" describeValue List{} = "list" 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,4 +1,4 @@ -{-# Language FlexibleInstances, OverloadedStrings #-} +{-# Language ScopedTypeVariables, OverloadedStrings #-} {-| Module : Config.Schema.Spec @@ -30,6 +30,11 @@ , listSpec , customSpec , namedSpec + , numberSpec + , integerSpec + , naturalSpec + , rationalSpec + , textSpec , HasSpec(..) -- * Specifying sections @@ -43,6 +48,7 @@ -- * Derived specifications , oneOrList , yesOrNoSpec + , trueOrFalseSpec , stringSpec , numSpec , fractionalSpec @@ -51,7 +57,7 @@ ) where -import Data.Bits (Bits, toIntegralSized) +import Data.Bits (FiniteBits, isSigned, toIntegralSized, finiteBitSize) import Data.Functor.Alt (Alt(..)) import Data.Int import Data.List.NonEmpty (NonEmpty) @@ -59,8 +65,11 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Word +import Data.Ratio +import GHC.Natural (Natural) import Config.Schema.Types +import Config.Number (Number, numberToInteger, numberToRational) ------------------------------------------------------------------------ -- 'ValueSpec' builders @@ -139,35 +148,72 @@ -- > username: random -- > -- Generates: Config { userName = Random, retries = 5 } --- | Class of value specifications that don't require arguments. +-- | Class of value specifications without parameters. class HasSpec a where anySpec :: ValueSpec a -instance HasSpec Text where anySpec = primValueSpec TextSpec -instance HasSpec Integer where anySpec = primValueSpec IntegerSpec -instance HasSpec Rational where anySpec = primValueSpec RationalSpec -instance HasSpec Int where anySpec = sizedBitsSpec "machine-bit signed" -instance HasSpec Int8 where anySpec = sizedBitsSpec "8-bit signed" -instance HasSpec Int16 where anySpec = sizedBitsSpec "16-bit signed" -instance HasSpec Int32 where anySpec = sizedBitsSpec "32-bit signed" -instance HasSpec Int64 where anySpec = sizedBitsSpec "64-bit signed" -instance HasSpec Word where anySpec = sizedBitsSpec "machine-bit unsigned" -instance HasSpec Word8 where anySpec = sizedBitsSpec "8-bit unsigned" -instance HasSpec Word16 where anySpec = sizedBitsSpec "16-bit unsigned" -instance HasSpec Word32 where anySpec = sizedBitsSpec "32-bit unsigned" -instance HasSpec Word64 where anySpec = sizedBitsSpec "64-bit unsigned" +instance HasSpec Text where anySpec = textSpec +instance HasSpec Integer where anySpec = integerSpec +instance HasSpec Int where anySpec = sizedBitsSpec +instance HasSpec Int8 where anySpec = sizedBitsSpec +instance HasSpec Int16 where anySpec = sizedBitsSpec +instance HasSpec Int32 where anySpec = sizedBitsSpec +instance HasSpec Int64 where anySpec = sizedBitsSpec +instance HasSpec Word where anySpec = sizedBitsSpec +instance HasSpec Word8 where anySpec = sizedBitsSpec +instance HasSpec Word16 where anySpec = sizedBitsSpec +instance HasSpec Word32 where anySpec = sizedBitsSpec +instance HasSpec Word64 where anySpec = sizedBitsSpec +-- | @since 1.2.0.0 +instance HasSpec Natural where anySpec = naturalSpec + +-- | @since 1.2.0.0 +instance HasSpec Double where anySpec = fractionalSpec + +-- | @since 1.2.0.0 +instance HasSpec Float where anySpec = fractionalSpec + +-- | For 'Ratio' and 'Rational' +-- +-- @since 1.2.0.0 +instance Integral a => HasSpec (Ratio a) where + anySpec = fractionalSpec + +-- | Zero or more elements in a list instance HasSpec a => HasSpec [a] where - anySpec = primValueSpec (ListSpec anySpec) + anySpec = listSpec anySpec +-- | One or more elements in a list +-- +-- @since 1.2.0.0 +instance HasSpec a => HasSpec (NonEmpty a) where + anySpec = nonemptySpec anySpec + +-- | Left-biased, untagged union of specs instance (HasSpec a, HasSpec b) => HasSpec (Either a b) where anySpec = Left <$> anySpec Right <$> anySpec -sizedBitsSpec :: (Integral a, Bits a) => Text -> ValueSpec a -sizedBitsSpec name = customSpec name (primValueSpec IntegerSpec) check +{-# INLINE sizedBitsSpec #-} +sizedBitsSpec :: forall a. (Integral a, FiniteBits a) => ValueSpec a +sizedBitsSpec = customSpec label integerSpec check where + signText = if isSigned (0::a) then "signed" else "unsigned" + + label = Text.pack (show (finiteBitSize (0::a)) ++ "-bit " ++ signText) + check i = case toIntegralSized i of Nothing -> Left "out of bounds" Just j -> Right j +-- | Specification for matching any non-negative, integral number +-- +-- @since 1.2.0.0 +naturalSpec :: ValueSpec Natural +naturalSpec = customSpec "non-negative" integerSpec check + where + check i + | i < 0 = Left "negative number" + | otherwise = Right (fromInteger i) + -- | Specification for matching a particular atom. atomSpec :: Text -> ValueSpec () atomSpec = primValueSpec . AtomSpec @@ -178,18 +224,47 @@ -- | Specification for matching any text as a 'String' stringSpec :: ValueSpec String -stringSpec = Text.unpack <$> anySpec +stringSpec = Text.unpack <$> textSpec -- | Specification for matching any integral number. numSpec :: Num a => ValueSpec a -numSpec = fromInteger <$> anySpec +numSpec = fromInteger <$> integerSpec +-- | Specification for matching any text literal +-- +-- @since 1.2.0.0 +textSpec :: ValueSpec Text +textSpec = primValueSpec TextSpec + -- | Specification for matching any fractional number. -- -- @since 0.2.0.0 fractionalSpec :: Fractional a => ValueSpec a -fractionalSpec = fromRational <$> anySpec +fractionalSpec = fromRational <$> rationalSpec +-- | Specification for matching any fractional number. +-- +-- @since 1.2.0.0 +numberSpec :: ValueSpec Number +numberSpec = primValueSpec NumberSpec + +-- | Specification for matching any integral number. +-- +-- @since 1.2.0.0 +integerSpec :: ValueSpec Integer +integerSpec = customSpec "integral" numberSpec check + where + check n = + case numberToInteger n of + Nothing -> Left "fractional number" + Just i -> Right i + +-- | Specification for matching any number as a 'Rational'. +-- +-- @since 1.2.0.0 +rationalSpec :: ValueSpec Rational +rationalSpec = numberToRational <$> numberSpec + -- | Specification for matching a list of values each satisfying a -- given element specification. listSpec :: ValueSpec a -> ValueSpec [a] @@ -241,12 +316,17 @@ customSpec lbl w f = primValueSpec (CustomSpec lbl (f <$> w)) --- | Specification for using @yes@ and @no@ to represent booleans 'True' +-- | Specification for using atoms @yes@ and @no@ to represent booleans 'True' -- and 'False' respectively yesOrNoSpec :: ValueSpec Bool -yesOrNoSpec = True <$ atomSpec (Text.pack "yes") - False <$ atomSpec (Text.pack "no") +yesOrNoSpec = True <$ atomSpec "yes" False <$ atomSpec "no" +-- | Specification for using atoms @true@ and @false@ to represent booleans 'True' +-- and 'False' respectively. +-- +-- @since 1.2.0.0 +trueOrFalseSpec :: ValueSpec Bool +trueOrFalseSpec = True <$ atomSpec "true" False <$ atomSpec "false" -- | Matches a non-empty list. -- diff --git a/src/Config/Schema/Types.hs b/src/Config/Schema/Types.hs --- a/src/Config/Schema/Types.hs +++ b/src/Config/Schema/Types.hs @@ -36,6 +36,7 @@ ) where +import Config.Number (Number) import Control.Applicative (Const(..)) import Control.Applicative.Free (Ap, liftAp, runAp, runAp_) import Data.Functor.Alt (Alt(..)) @@ -58,11 +59,8 @@ -- | Matches any string literal TextSpec :: PrimValueSpec Text - -- | Matches integral numbers - IntegerSpec :: PrimValueSpec Integer - - -- | Matches any number - RationalSpec :: PrimValueSpec Rational + -- | Matches numbers + NumberSpec :: PrimValueSpec Number -- | Matches any atom AnyAtomSpec :: PrimValueSpec Text