diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for config-schema +## 1.2.1.0 + +* Expose `Config.Schema.Load.Error.simplifyValueSpecMismatch` + for providing more focused error feedback. +* Added `instance ErrorAnnotation FilePosition` + ## 1.2.0.0 * Update to build against `config-value-0.7.0.0` diff --git a/config-schema.cabal b/config-schema.cabal --- a/config-schema.cabal +++ b/config-schema.cabal @@ -1,12 +1,7 @@ cabal-version: 2.2 name: config-schema -version: 1.2.0.0 +version: 1.2.1.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. - These schemas can be used to be process a configuration file into - a Haskell value, or to automatically generate documentation for - the file format. license: ISC license-file: LICENSE author: Eric Mertens @@ -17,11 +12,18 @@ 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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.2 +description: + This package makes it possible to define schemas for use when + loading configuration files using the config-value format. + These schemas can be used to process a configuration file into + a Haskell value or to automatically generate documentation for + the file format. + source-repository head - type: git - location: https://github.com/glguy/config-schema + type: git + location: https://github.com/glguy/config-schema library exposed-modules: @@ -33,8 +35,8 @@ Config.Schema.Types build-depends: - base >=4.8 && <4.14, - config-value ^>=0.7, + base >=4.9 && <4.15, + config-value ^>=0.8, containers >=0.5 && <0.7, free >=4.12 && <5.2, kan-extensions >=5.0.2 && <5.3, @@ -43,11 +45,6 @@ text >=1.2 && <1.3, transformers >=0.4 && <0.6, - if flag(use-semigroups) - build-depends: base <4.9, semigroups >=0.18 && <0.19 - else - build-depends: base >= 4.9 - hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -59,7 +56,3 @@ build-depends: base, config-value, config-schema, text default-language: Haskell2010 ghc-options: -Wall - -flag use-semigroups - default: False - manual: False 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 @@ -33,6 +33,7 @@ -- * Summaries , describeSpec , describeValue + , simplifyValueSpecMismatch ) where import Control.Exception @@ -47,6 +48,7 @@ punctuate, comma, int, colon, hcat) import Config +import Config.Macro (FilePosition(..)) import Config.Schema.Types #if !MIN_VERSION_base(4,11,0) @@ -54,6 +56,8 @@ #endif -- | Newtype wrapper for schema load errors. +-- +-- @since 1.2.0.0 data ValueSpecMismatch p = -- | Problem value and list of specification failures ValueSpecMismatch p Text (NonEmpty (PrimMismatch p)) @@ -62,6 +66,8 @@ -- | 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. +-- +-- @since 1.2.0.0 data PrimMismatch p = -- | spec description and problem PrimMismatch Text (Problem p) @@ -69,6 +75,8 @@ -- | Problems that can be encountered when matching a 'Value' against a 'ValueSpec'. +-- +-- @since 1.2.0.0 data Problem p = MissingSection Text -- ^ missing section name | UnusedSections (NonEmpty Text) -- ^ unused section names @@ -81,6 +89,8 @@ deriving Show -- | Describe outermost shape of a 'PrimValueSpec' +-- +-- @since 1.2.0.0 describeSpec :: PrimValueSpec a -> Text describeSpec TextSpec = "text" describeSpec NumberSpec = "number" @@ -122,17 +132,15 @@ = ValueSpecMismatch p v xs' removeTypeMismatch1 v = v +-- | Returns 'True' for schema mismatches where the value type doesn't +-- match. isTypeMismatch :: PrimMismatch p -> Bool isTypeMismatch (PrimMismatch _ prob) = case prob of - WrongAtom -> True - TypeMismatch -> True - NestedProblem x -> go x - SubkeyProblem _ x -> go x - ListElementProblem _ x -> go x - _ -> False - where - go (ValueSpecMismatch _ _ xs) = all isTypeMismatch xs + WrongAtom -> True + TypeMismatch -> True + NestedProblem (ValueSpecMismatch _ _ xs) -> all isTypeMismatch xs + _ -> False -- | Single-step rewrite that removes mismatches with only a single, -- nested mismatch below them. @@ -151,6 +159,8 @@ -- | Pretty-printer for 'ValueSpecMismatch' showing the position -- and type of value that failed to match along with details about -- each specification that it didn't match. +-- +-- @since 1.2.0.0 prettyValueSpecMismatch :: ErrorAnnotation p => ValueSpecMismatch p -> Doc prettyValueSpecMismatch (ValueSpecMismatch p v es) = heading $+$ errors @@ -162,14 +172,27 @@ -- | Pretty-printer for 'PrimMismatch' showing a summary of the primitive -- specification that didn't match followed by a more detailed error when -- appropriate. +-- +-- @since 1.2.0.0 prettyPrimMismatch :: ErrorAnnotation p => PrimMismatch p -> Doc prettyPrimMismatch (PrimMismatch spec problem) = case prettyProblem problem of (summary, detail) -> - (text "*" <+> text (Text.unpack spec) <+> summary) $+$ nest 4 detail + (text "* expected" <+> text (Text.unpack spec) <+> summary) $+$ nest 4 detail +-- | Simplify a 'ValueSpecMismatch' by collapsing long nested error +-- cases and by assuming that if a type matched that the other mismatched +-- type alternatives are uninteresting. This is used in the implementation +-- of 'displayException'. +-- +-- @since 1.2.1.0 +simplifyValueSpecMismatch :: ValueSpecMismatch p -> ValueSpecMismatch p +simplifyValueSpecMismatch = rewriteMismatch (focusMismatch1 . removeTypeMismatch1) + -- | Pretty-printer for 'Problem' that generates a summary line -- as well as a detailed description (depending on the error) +-- +-- @since 1.2.0.0 prettyProblem :: ErrorAnnotation p => Problem p -> @@ -203,17 +226,29 @@ , prettyValueSpecMismatch e) -- | Class for rendering position annotations within the 'prettyValueSpecMismatch' +-- +-- @since 1.2.0.0 class (Typeable a, Show a) => ErrorAnnotation a where displayAnnotation :: a -> Doc -- | Renders a 'Position' as @line:column:@ +-- +-- @since 1.2.0.0 instance ErrorAnnotation Position where displayAnnotation pos = hcat [int (posLine pos), colon, int (posColumn pos), colon] +instance ErrorAnnotation FilePosition where + displayAnnotation (FilePosition path pos) = hcat [text path, colon, int (posLine pos), colon, int (posColumn pos), colon] + -- | Renders as an empty document +-- +-- @since 1.2.0.0 instance ErrorAnnotation () where displayAnnotation _ = empty -- | 'displayException' implemented with 'prettyValueSpecMismatch' +-- and 'simplifyValueSpecMismatch'. +-- +-- @since 1.2.0.0 instance ErrorAnnotation p => Exception (ValueSpecMismatch p) where - displayException = show . prettyValueSpecMismatch . rewriteMismatch (focusMismatch1 . removeTypeMismatch1) + displayException = show . prettyValueSpecMismatch . simplifyValueSpecMismatch 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 @@ -15,46 +15,61 @@ This is the schema system used by the @glirc@ IRC client . For a significant example, -visit the "Client.Configuration" and "Client.Configuration.Colors" modules. +visit the @Client.Configuration@ and @Client.Configuration.Colors@ modules. -} module Config.Schema.Spec ( -- * Specifying values -- $values + ValueSpec - , sectionsSpec - , assocSpec - , atomSpec - , anyAtomSpec - , listSpec , customSpec , namedSpec + , HasSpec(..) + + -- ** Key-value mapping specifications + -- $sections + , sectionsSpec + , assocSpec + + -- ** Number specifications + -- $number , numberSpec , integerSpec - , naturalSpec , rationalSpec + , naturalSpec + , fractionalSpec + , numSpec + + -- ** Text specifications + -- $text , textSpec - , HasSpec(..) + , stringSpec + -- ** Atom specifications + -- $atom + , atomSpec + , anyAtomSpec + , yesOrNoSpec + , trueOrFalseSpec + + -- ** List specifications + -- $list + , listSpec + , oneOrList + , nonemptySpec + , oneOrNonemptySpec + + -- * Specifying sections - -- $sections + -- $sectionsspec , SectionsSpec , reqSection , optSection , reqSection' , optSection' - -- * Derived specifications - , oneOrList - , yesOrNoSpec - , trueOrFalseSpec - , stringSpec - , numSpec - , fractionalSpec - , nonemptySpec - , oneOrNonemptySpec - ) where import Data.Bits (FiniteBits, isSigned, toIntegralSized, finiteBitSize) @@ -192,6 +207,58 @@ instance (HasSpec a, HasSpec b) => HasSpec (Either a b) where anySpec = Left <$> anySpec Right <$> anySpec +-- | Named value specification. This is useful for factoring complicated +-- value specifications out in the documentation to avoid repetition of +-- complex specifications. +namedSpec :: + Text {- ^ name -} -> + ValueSpec a {- ^ underlying specification -} -> + ValueSpec a +namedSpec n s = primValueSpec (NamedSpec n s) + + +-- | The custom specification allows an arbitrary function to be used +-- to validate the value extracted by a specification. If 'Nothing' +-- is returned the value is considered to have failed validation. +customSpec :: Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b +customSpec lbl w f = primValueSpec (CustomSpec lbl (f <$> w)) + +------------------------------------------------------------------------ + +-- $sections +-- Specifications that match key-value map literals. + +-- | Named subsection value specification. The unique identifier will be used +-- for generating a documentation section for this specification and should +-- be unique within the scope of the specification being built. +sectionsSpec :: + Text {- ^ unique documentation identifier -} -> + SectionsSpec a {- ^ underlying specification -} -> + ValueSpec a +sectionsSpec i s = primValueSpec (SectionsSpec i s) + + +-- | Specification for a section list where the keys are user-defined. +-- Values are matched against the underlying specification and returned +-- as a list of section-name\/value pairs. +-- +-- @since 0.3.0.0 +assocSpec :: + ValueSpec a {- ^ underlying specification -} -> + ValueSpec [(Text,a)] +assocSpec = primValueSpec . AssocSpec + +------------------------------------------------------------------------ + +-- $number +-- Specifications built from 'numberSpec' matching number literals. + +-- | Primitive specification for matching any number. +-- +-- @since 1.2.0.0 +numberSpec :: ValueSpec Number +numberSpec = primValueSpec NumberSpec + {-# INLINE sizedBitsSpec #-} sizedBitsSpec :: forall a. (Integral a, FiniteBits a) => ValueSpec a sizedBitsSpec = customSpec label integerSpec check @@ -214,40 +281,16 @@ | i < 0 = Left "negative number" | otherwise = Right (fromInteger i) --- | Specification for matching a particular atom. -atomSpec :: Text -> ValueSpec () -atomSpec = primValueSpec . AtomSpec - --- | Specification for matching any atom. Matched atom is returned. -anyAtomSpec :: ValueSpec Text -anyAtomSpec = primValueSpec AnyAtomSpec - --- | Specification for matching any text as a 'String' -stringSpec :: ValueSpec String -stringSpec = Text.unpack <$> textSpec - -- | Specification for matching any integral number. numSpec :: Num a => ValueSpec a 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 <$> 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 @@ -265,56 +308,20 @@ rationalSpec :: ValueSpec Rational rationalSpec = numberToRational <$> numberSpec --- | Specification for matching a list of values each satisfying a --- given element specification. -listSpec :: ValueSpec a -> ValueSpec [a] -listSpec = primValueSpec . ListSpec - - --- | Named subsection value specification. The unique identifier will be used --- for generating a documentation section for this specification and should --- be unique within the scope of the specification being built. -sectionsSpec :: - Text {- ^ unique documentation identifier -} -> - SectionsSpec a {- ^ underlying specification -} -> - ValueSpec a -sectionsSpec i s = primValueSpec (SectionsSpec i s) - - --- | Specification for a section list where the keys are user-defined. --- Values are matched against the underlying specification and returned --- as a list of section-name\/value pairs. --- --- @since 0.3.0.0 -assocSpec :: - ValueSpec a {- ^ underlying specification -} -> - ValueSpec [(Text,a)] -assocSpec = primValueSpec . AssocSpec - - --- | Named value specification. This is useful for factoring complicated --- value specifications out in the documentation to avoid repetition of --- complex specifications. -namedSpec :: - Text {- ^ name -} -> - ValueSpec a {- ^ underlying specification -} -> - ValueSpec a -namedSpec n s = primValueSpec (NamedSpec n s) - - --- | Specification that matches either a single element or multiple --- elements in a list. This can be convenient for allowing the user --- to avoid having to specify singleton lists in the configuration file. -oneOrList :: ValueSpec a -> ValueSpec [a] -oneOrList s = pure <$> s listSpec s +------------------------------------------------------------------------ +-- $atom +-- Specifications built to match atoms. --- | The custom specification allows an arbitrary function to be used --- to validate the value extracted by a specification. If 'Nothing' --- is returned the value is considered to have failed validation. -customSpec :: Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b -customSpec lbl w f = primValueSpec (CustomSpec lbl (f <$> w)) +-- | Primitive specification for matching a particular atom. +atomSpec :: + Text {- ^ atom -} -> + ValueSpec () +atomSpec = primValueSpec . AtomSpec +-- | Primitive specification for matching any atom. Matched atom is returned. +anyAtomSpec :: ValueSpec Text +anyAtomSpec = primValueSpec AnyAtomSpec -- | Specification for using atoms @yes@ and @no@ to represent booleans 'True' -- and 'False' respectively @@ -328,10 +335,39 @@ trueOrFalseSpec :: ValueSpec Bool trueOrFalseSpec = True <$ atomSpec "true" False <$ atomSpec "false" +------------------------------------------------------------------------ + +-- $text +-- Specifications built from 'textSpec' for matching string literals. + +-- | Specification for matching any text literal +-- +-- @since 1.2.0.0 +textSpec :: ValueSpec Text +textSpec = primValueSpec TextSpec + +-- | Specification for matching any text as a 'String' +stringSpec :: ValueSpec String +stringSpec = Text.unpack <$> textSpec + +------------------------------------------------------------------------ + +-- $list +-- Specifications for matching list literals built with 'listSpec. + +-- | Primitive specification for matching a list of values each satisfying a +-- given element specification. +listSpec :: + ValueSpec a {- ^ element specification -} -> + ValueSpec [a] +listSpec = primValueSpec . ListSpec + -- | Matches a non-empty list. -- -- @since 0.2.0.0 -nonemptySpec :: ValueSpec a -> ValueSpec (NonEmpty a) +nonemptySpec :: + ValueSpec a {- ^ element specification -} -> + ValueSpec (NonEmpty a) nonemptySpec s = customSpec "nonempty" (listSpec s) check where check xs = case NonEmpty.nonEmpty xs of @@ -341,15 +377,24 @@ -- | Matches a single element or a non-empty list. -- -- @since 0.2.0.0 -oneOrNonemptySpec :: ValueSpec a -> ValueSpec (NonEmpty a) +oneOrNonemptySpec :: + ValueSpec a {- ^ element specification -} -> + ValueSpec (NonEmpty a) oneOrNonemptySpec s = pure <$> s nonemptySpec s +-- | Specification that matches either a single element or multiple +-- elements in a list. This can be convenient for allowing the user +-- to avoid having to specify singleton lists in the configuration file. +oneOrList :: + ValueSpec a {- ^ element specification -} -> + ValueSpec [a] +oneOrList s = pure <$> s listSpec s ------------------------------------------------------------------------ -- 'SectionsSpec' builders ------------------------------------------------------------------------ --- $sections +-- $sectionsspec -- Sections specifications allow you to define an unordered collection -- of required and optional sections using a convenient 'Applicative' -- do-notation syntax.