config-schema-1.3.0.0/0000755000000000000000000000000007346545000012545 5ustar0000000000000000config-schema-1.3.0.0/ChangeLog.md0000644000000000000000000000501607346545000014720 0ustar0000000000000000# Revision history for config-schema ## 1.3.0.0 * Generalize atomSpec to suport arbitrary exactSpec matches ## 1.2.2.0 * Re-export `Alt` from `Config.Schema.Spec` ## 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` * 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` * More aggressively eliminate `TypeMismatch` and `WrongAtom` when other, more specific errors, are available. ## 1.0.0.0 * Rename `ValueSpec` to `PrimValueSpec` * Rename `ValueSpecs` to `ValueSpec` * Rename `SectionSpec` to `PrimSectionSpec` * Rename `SectionSpecs` to `SectionsSpec` * Rename `Spec` class to `HasSpec` * Rename `valuesSpec` to `anySpec` * Custom specifications changed type to expose an error message. * Move spec types to `Config.Schema.Types`. Now `Config.Schema.Spec` has only the exports needed for building specs and not defining new spec consumers. * Improve schema mismatch type and errors in `Config.Schema.Load.Error` ## 0.5.0.1 * Support GHC 8.4.1 ## 0.5.0.0 * Add Spec instances for Int and Word types. All instances including the previous Int instance now validate ranges. * Changed argument order for `loadValueFromFile` ## 0.4.1.0 * Add `loadValueFromFile` and `SchemaError`. This is intended as a quick way to get a configuration file loaded with all errors being thrown as exceptions. ## 0.4.0.0 * Parameterize the Load module on a position type * Allow Docs module to process recursively defined specifications as long as a named section breaks the loop. * Add parentheses to docs when needed ## 0.3.1.1 -- 2017-05-17 * Add support for GHC 7.10.3 ## 0.3.1.0 -- 2017-05-16 * Allow `generateDocs` to work on any ValueSpec, rather than top-level empty-named section specs. ## 0.3.0.0 -- 2017-05-09 * Added "association list" specifications * Use `pretty` library for documentation generation * Reorder parameters so that documentation comes last * Hide implementations of `ValueSpecs` and `SectionSpecs` ## 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. config-schema-1.3.0.0/LICENSE0000644000000000000000000000133207346545000013551 0ustar0000000000000000Copyright (c) 2017 Eric Mertens Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. config-schema-1.3.0.0/README.md0000644000000000000000000000576507346545000014041 0ustar0000000000000000config-schema ============= [![Hackage](https://img.shields.io/hackage/v/config-schema.svg)](https://hackage.haskell.org/package/config-schema) [![Build Status](https://secure.travis-ci.org/glguy/config-schema.png?branch=master)](http://travis-ci.org/glguy/config-schema) Live Demo -------- The config-value and config-schema packages are available in a [live demo](https://glguy.net/config-demo/). About -------- This package allows the user to define configuration schemas suitable for matching against configuration files written in the [config-value](https://hackage.haskell.org/package/config-value) format. These schemas allow the user to extract an arbitrary Haskell value from an interpretation of a configuration file. It also allows the user to programatically generate documentation for the configuration files accepted by the loader. ```haskell {-# Language OverloadedStrings, ApplicativeDo #-} module Example where import qualified Data.Text as Text import Data.Text (Text) import Data.Monoid ((<>)) import Data.Functor.Alt (()) import Data.List.NonEmpty (NonEmpty) import Config import Config.Schema exampleFile :: Text exampleFile = " name: \"Johny Appleseed\" \n\ \ age : 99 \n\ \ happy: yes \n\ \ kids: \n\ \ * name: \"Bob\" \n\ \ * name: \"Tom\" \n" exampleValue :: Value Position Right exampleValue = parse exampleFile exampleSpec :: ValueSpec Text exampleSpec = sectionsSpec "" $ do name <- reqSection "name" "Full name" age <- reqSection "age" "Age of user" happy <- optSection' "happy" yesOrNo "Current happiness status" kids <- reqSection' "kids" (oneOrList kidSpec) "All children's names" return $ let happyText = case happy of Just True -> " and is happy" Just False -> " and is not happy" Nothing -> " and is private" in name <> " is " <> Text.pack (show (age::Integer)) <> " years old and has kids " <> Text.intercalate ", " kids <> happyText kidSpec :: ValueSpec Text kidSpec = sectionsSpec "kid" (reqSection "name" "Kid's name") -- | Matches the 'yes' and 'no' atoms yesOrNo :: ValueSpec Bool yesOrNo = True <$ atomSpec "yes" False <$ atomSpec "no" printDoc :: IO () printDoc = print (generateDocs exampleSpec) -- *Example> printDoc -- Top-level configuration file fields: -- name: REQUIRED text -- Full name -- age: REQUIRED integer -- Age of user -- happy: `yes` or `no` -- Current happiness status -- kids: REQUIRED kid or list of kid -- All children -- -- kid -- name: REQUIRED text -- Kid's name example :: Either (NonEmpty (LoadError Position)) Text example = loadValue exampleSpec exampleValue -- *Example> exampleVal -- Right "Johny Appleseed is 99 years old and has kids Bob, Tom and is happy" ``` config-schema-1.3.0.0/Setup.hs0000644000000000000000000000005607346545000014202 0ustar0000000000000000import Distribution.Simple main = defaultMain config-schema-1.3.0.0/config-schema.cabal0000644000000000000000000000353307346545000016240 0ustar0000000000000000cabal-version: 2.2 name: config-schema version: 1.3.0.0 synopsis: Schema definitions for the config-value package license: ISC license-file: LICENSE author: Eric Mertens maintainer: emertens@gmail.com copyright: Eric Mertens 2017 category: Language build-type: Simple 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.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 library exposed-modules: Config.Schema Config.Schema.Docs Config.Schema.Load Config.Schema.Load.Error Config.Schema.Spec Config.Schema.Types build-depends: base >=4.9 && <4.18, config-value ^>=0.8.3, containers >=0.5 && <0.7, free >=4.12 && <5.2, kan-extensions >=5.0.2 && <5.3, pretty >=1.1.2 && <1.2, semigroupoids >=5.1 && <5.4, text >=1.2 && <2.1, transformers >=0.4 && <0.7, hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall test-suite unit-tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests build-depends: base, config-value, config-schema, text default-language: Haskell2010 ghc-options: -Wall config-schema-1.3.0.0/src/Config/0000755000000000000000000000000007346545000014541 5ustar0000000000000000config-schema-1.3.0.0/src/Config/Schema.hs0000644000000000000000000000175307346545000016303 0ustar0000000000000000{-| Module : Config.Schema Description : Top-level module rexporting child modules Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com This package makes it possible to define schemas for configuration files. 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. "Config.Schema.Docs" generates textual documentation for a schema. -} module Config.Schema ( module Config.Schema.Spec , module Config.Schema.Docs , module Config.Schema.Load ) where import Config.Schema.Docs import Config.Schema.Load import Config.Schema.Spec config-schema-1.3.0.0/src/Config/Schema/0000755000000000000000000000000007346545000015741 5ustar0000000000000000config-schema-1.3.0.0/src/Config/Schema/Docs.hs0000644000000000000000000001451707346545000017175 0ustar0000000000000000{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving, CPP #-} {-| Module : Config.Schema.Docs Description : Documentation generation for config schemas Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com This module generates a simple textual documentation format for a configuration schema. Each subsection and named value specification will generate it's own top-level component in the documentation. This module is only one of the ways one could generate documentation for a particular configuration specification. All of the defintions would would need to be able to generate another form are exported by "Config.Schema.Spec". @ configSpec :: ValueSpec (Text,Maybe Int) configSpec = sectionsSpec "" $ liftA2 (,) (reqSection "username" "Name used to login") (optSection "attempts" "Number of login attempts") generateDocs configSpec -- Top-level configuration file fields: -- username: REQUIRED text -- Name used to login -- attempts: integer -- Number of login attempts @ -} module Config.Schema.Docs ( generateDocs ) where import Control.Applicative (liftA2) import Control.Monad (unless) import Control.Monad.Trans.State.Strict (runState, get, put, State) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Semigroup as S import Data.Text (Text) import qualified Data.Text as Text import Text.PrettyPrint (Doc, fsep, text, (<>), ($+$), (<+>), nest, empty, hsep, parens) import Prelude hiding ((<>)) #if !MIN_VERSION_base(4,11,0) import Data.Monoid (Monoid(..)) #endif import Config import Config.Schema.Spec import Config.Schema.Types -- | Default documentation generator. generateDocs :: ValueSpec a -> Doc generateDocs spec = vcat' docLines where sectionLines :: (Text, Doc) -> [Doc] sectionLines (name, fields) = [text "", txt name, nest 4 fields] (topDoc, topMap) = runDocBuilder (valuesDoc False spec) docLines = case runValueSpec_ (pure . SomeSpec) spec of -- single, top-level sections spec SomeSpec (SectionsSpec name _) :| [] | Just top <- Map.lookup name topMap -> txt "Top-level configuration file fields:" : nest 4 top : concatMap sectionLines (Map.toList (Map.delete name topMap)) -- otherwise _ -> txt "Top-level configuration file format:" : nest 4 topDoc : concatMap sectionLines (Map.toList topMap) -- | Forget the type of the value spec data SomeSpec where SomeSpec :: PrimValueSpec a -> SomeSpec -- | Compute the documentation for a list of sections, store the -- documentation in the sections map and return the name of the section. sectionsDoc :: Text -> SectionsSpec a -> DocBuilder Doc sectionsDoc l spec = emitDoc l (vcat' <$> runSections_ (fmap pure . sectionDoc) spec) -- | Compute the documentation lines for a single key-value pair. sectionDoc :: PrimSectionSpec a -> DocBuilder Doc sectionDoc s = case s of ReqSection name desc w -> aux "REQUIRED" name desc <$> valuesDoc False w OptSection name desc w -> aux empty name desc <$> valuesDoc False w where aux req name desc val = (txt name <> ":") <+> req <+> val $+$ if Text.null desc then empty else nest 4 (fsep (txt <$> Text.splitOn " " desc)) -- line wrap logic -- | Compute the documentation line for a particular value specification. -- Any sections contained in the specification will be stored in the -- sections map. -- -- Set nested to 'True' when using valuesDoc in a nested context and -- parentheses would be needed in the case of multiple alternatives. valuesDoc :: Bool {- ^ nested -} -> ValueSpec a -> DocBuilder Doc valuesDoc nested = fmap (disjunction nested) . sequenceA . runValueSpec_ (fmap pure valueDoc) -- | Combine a list of text with the word @or@. disjunction :: Bool {- ^ nested -} -> [Doc] -> Doc disjunction _ [x] = x disjunction True xs = parens (hsep (intersperse "or" xs)) disjunction False xs = hsep (intersperse "or" xs) -- | Compute the documentation fragment for an individual value specification. valueDoc :: PrimValueSpec a -> DocBuilder Doc valueDoc w = case w of TextSpec -> pure "text" NumberSpec -> pure "number" AtomSpec -> pure "atom" SectionsSpec l s -> sectionsDoc l s NamedSpec l s -> emitDoc l (valuesDoc False s) CustomSpec l w' -> (txt l <+>) <$> valuesDoc True w' ListSpec ws -> ("list of" <+>) <$> valuesDoc True ws AssocSpec ws -> ("association list of" <+>) <$> valuesDoc True ws ExactSpec v -> pure ("`" <> prettyInline v <> "`") -- | A writer-like type. A mapping of section names and documentation -- lines is accumulated. newtype DocBuilder a = DocBuilder (State (Map Text Doc) a) deriving (Functor, Applicative, Monad) runDocBuilder :: DocBuilder a -> (a, Map Text Doc) runDocBuilder (DocBuilder b) = runState b mempty -- | lifts underlying 'S.Semigroup' instance instance S.Semigroup a => S.Semigroup (DocBuilder a) where (<>) = liftA2 (S.<>) -- | lifts underlying 'Monoid' instance instance (S.Semigroup a, Monoid a) => Monoid (DocBuilder a) where mempty = pure mempty mappend = (S.<>) -- | Given a section name and section body, store the body -- in the map of sections and return the section name. emitDoc :: Text {- ^ section name -} -> DocBuilder Doc {- ^ section body -} -> DocBuilder Doc {- ^ section name doc -} emitDoc l (DocBuilder sub) = DocBuilder $ do m <- get unless (Map.member l m) $ do rec put $! Map.insert l val m val <- sub return () return (txt l) -- by using a recursively defined do block and -- inserting the element /before/ executing the @sub@ -- action we ensure that @sub@ doesn't attempt to -- also explore elements named @l@ ------------------------------------------------------------------------ -- | Like text, but works on Text values. txt :: Text -> Doc txt = text . Text.unpack -- | Like vcat but using ($+$) instead of ($$) to avoid overlap. vcat' :: [Doc] -> Doc vcat' = foldr ($+$) empty config-schema-1.3.0.0/src/Config/Schema/Load.hs0000644000000000000000000001307407346545000017161 0ustar0000000000000000{-# Language GADTs #-} {-| Module : Config.Schema.Load Description : Operations to extract a value from a configuration. Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com This module automates the extraction of a decoded value from a configuration value according to a specification as built using "Config.Schema.Spec". -} module Config.Schema.Load ( loadValue , loadValueFromFile -- * Errors , ValueSpecMismatch(..) , PrimMismatch(..) , Problem(..) ) where import Control.Exception (throwIO) import Control.Monad (zipWithM) 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.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text.IO as Text import Config import Config.Schema.Types import Config.Schema.Load.Error -- | Match a 'Value' against a 'ValueSpec' and return either -- the interpretation of that value or the list of errors -- encountered. loadValue :: ValueSpec a {- ^ specification -} -> Value p {- ^ value -} -> Either (ValueSpecMismatch p) a {- ^ errors or decoded value -} loadValue spec val = runExcept (getValue spec val) -- | Read a configuration file, parse it, and validate it according -- to the given specification. -- -- Throws 'IOError', 'ParseError', or 'ValueSpecMismatch' loadValueFromFile :: ValueSpec a {- ^ specification -} -> FilePath {- ^ filename -} -> IO a loadValueFromFile spec path = do txt <- Text.readFile path let exceptIO m = either throwIO return m val <- exceptIO (parse txt) exceptIO (loadValue spec val) getSection :: PrimSectionSpec a -> StateT [Section p] (Except (Problem p)) a getSection (ReqSection k _ w) = do mb <- state (lookupSection k) lift $ case mb of Just v -> getValue' (SubkeyProblem k) w v Nothing -> throwE (MissingSection k) getSection (OptSection k _ w) = do mb <- state (lookupSection k) lift (traverse (getValue' (SubkeyProblem k) w) mb) getSections :: SectionsSpec a -> [Section p] -> Except (Problem p) a getSections spec xs = do (a,leftovers) <- runStateT (runSections getSection spec) xs case NonEmpty.nonEmpty leftovers of Nothing -> return a Just ss -> throwE (UnusedSections (fmap sectionName ss)) getValue :: ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a getValue s v = withExcept (ValueSpecMismatch (valueAnn v) (describeValue v)) (runValueSpec (getValue1 v) s) -- | Match a 'Value' against a 'ValueSpec' given a wrapper for any nested -- mismatch errors that might occur. getValue' :: (ValueSpecMismatch p -> Problem p) -> ValueSpec a -> Value p -> Except (Problem p) a getValue' p s v = withExcept (p . ValueSpecMismatch (valueAnn v) (describeValue v)) (runValueSpec (getValue1 v) s) getValue1 :: Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a getValue1 v prim = withExcept (pure . PrimMismatch (describeSpec prim)) (getValue2 v prim) -- | 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) NumberSpec = pure n getValue2 (List _ xs) (ListSpec w) = getList w xs getValue2 (Atom _ b) AtomSpec = pure (atomName b) getValue2 v (ExactSpec w) | (() <$ v) == w = pure () | otherwise = throwE WrongExact getValue2 (Sections _ s) (SectionsSpec _ w) = getSections w s getValue2 (Sections _ s) (AssocSpec w) = getAssoc w s getValue2 v (NamedSpec _ w) = getValue' NestedProblem w v getValue2 v (CustomSpec _ w) = getCustom w v getValue2 _ _ = throwE TypeMismatch -- | This operation processes all of the values in a list with the given -- value specification and updates the scope with a one-based list index. getList :: ValueSpec a -> [Value p] -> Except (Problem p) [a] getList w = zipWithM (\i -> getValue' (ListElementProblem i) w) [1::Int ..] -- | This operation processes all of the values in a section list -- against the given specification and associates them with the -- section name. getAssoc :: ValueSpec a -> [Section p] -> Except (Problem p) [(Text,a)] getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> getValue' (SubkeyProblem k) w v -- | Match a value against its specification. If 'Just' is matched -- return the value. If 'Nothing is matched, report an error. getCustom :: ValueSpec (Either Text a) {- ^ specification -} -> Value p {- ^ value -} -> Except (Problem p) a getCustom w v = either (throwE . CustomProblem) pure =<< getValue' NestedProblem w v -- | Extract a section from a list of sections by name. lookupSection :: Text {- ^ section name -} -> [Section p] {- ^ available sections -} -> (Maybe (Value p), [Section p]) {- ^ found value and remaining sections -} lookupSection _ [] = (Nothing, []) lookupSection key (s@(Section _ k v):xs) | key == k = (Just v, xs) | otherwise = case lookupSection key xs of (res, xs') -> (res, s:xs') config-schema-1.3.0.0/src/Config/Schema/Load/0000755000000000000000000000000007346545000016620 5ustar0000000000000000config-schema-1.3.0.0/src/Config/Schema/Load/Error.hs0000644000000000000000000002154207346545000020251 0ustar0000000000000000{-# Language GADTs, OverloadedStrings, CPP #-} {-| Module : Config.Schema.Load.Error Description : Error types and rendering for Load module Copyright : (c) Eric Mertens, 2019 License : ISC Maintainer : emertens@gmail.com This module provides a complete skeleton of the failures that occurred when trying to match a 'Value' against a 'ValueSpec' allowing custom error rendering to be implemented. The structure is you get a single value and a list of one-or-more primitive specifications that it failed to match along with an enumeration of why that specification failed to match. Some failures are due to failures in nested specifications, so the whole error structure can form a tree. -} module Config.Schema.Load.Error ( -- * Error types ValueSpecMismatch(..) , PrimMismatch(..) , Problem(..) , ErrorAnnotation(..) -- * Detailed rendering , prettyValueSpecMismatch , prettyPrimMismatch , prettyProblem -- * Summaries , describeSpec , describeValue , simplifyValueSpecMismatch ) where import Control.Exception import Data.Text (Text) import Data.Foldable (toList) import qualified Data.Text as Text import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty import Data.Typeable (Typeable) import Text.PrettyPrint (Doc, fsep, ($+$), nest, text, vcat, (<+>), empty, punctuate, comma, int, colon, hcat) import Config import Config.Macro (FilePosition(..)) import Config.Schema.Types #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #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)) deriving Show -- | 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) deriving Show -- | 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 | SubkeyProblem Text (ValueSpecMismatch p) -- ^ nested error in given section | ListElementProblem Int (ValueSpecMismatch p) -- ^ nested error in given list element | NestedProblem (ValueSpecMismatch p) -- ^ generic nested error | TypeMismatch -- ^ value and spec type mismatch | CustomProblem Text -- ^ custom spec error message | WrongExact -- ^ values didn't match deriving Show -- | Describe outermost shape of a 'PrimValueSpec' -- -- @since 1.2.0.0 describeSpec :: PrimValueSpec a -> Text describeSpec TextSpec = "text" describeSpec NumberSpec = "number" describeSpec AtomSpec = "atom" describeSpec (ListSpec _) = "list" describeSpec (SectionsSpec name _) = name describeSpec (AssocSpec _) = "sections" describeSpec (CustomSpec name _) = name describeSpec (NamedSpec name _) = name describeSpec (ExactSpec v) = describeValue v -- | Describe outermost shape of a 'Value' describeValue :: Value p -> Text describeValue Text{} = "text" describeValue Number{} = "number" describeValue (Atom _ a) = "atom `" <> atomName a <> "`" describeValue Sections{} = "sections" describeValue List{} = "list" -- | Bottom-up transformation of a 'ValueSpecMismatch' rewriteMismatch :: (ValueSpecMismatch p -> ValueSpecMismatch p) -> ValueSpecMismatch p -> ValueSpecMismatch p rewriteMismatch f (ValueSpecMismatch p v prims) = f (ValueSpecMismatch p v (fmap aux1 prims)) where aux1 (PrimMismatch spec prob) = PrimMismatch spec (aux2 prob) aux2 (SubkeyProblem x y) = SubkeyProblem x (rewriteMismatch f y) aux2 (ListElementProblem x y) = ListElementProblem x (rewriteMismatch f y) aux2 (NestedProblem y) = NestedProblem (rewriteMismatch f y) aux2 prob = prob -- | Single-step rewrite that removes type-mismatch problems if there -- are non-mismatches available to focus on. removeTypeMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p removeTypeMismatch1 (ValueSpecMismatch p v xs) | Just xs' <- NonEmpty.nonEmpty (NonEmpty.filter (not . isTypeMismatch) xs) = 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 WrongExact -> True TypeMismatch -> True NestedProblem (ValueSpecMismatch _ _ xs) -> all isTypeMismatch xs _ -> False -- | Single-step rewrite that removes mismatches with only a single, -- nested mismatch below them. focusMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p focusMismatch1 x@(ValueSpecMismatch _ _ prims) | PrimMismatch _ problem :| [] <- prims , Just sub <- simplify1 problem = sub | otherwise = x where simplify1 (SubkeyProblem _ p) = Just p simplify1 (ListElementProblem _ p) = Just p simplify1 (NestedProblem p) = Just p simplify1 _ = Nothing -- | 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 where heading = displayAnnotation p <> text (Text.unpack v) errors = vcat (map prettyPrimMismatch (toList es)) -- | 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 "* 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 -> (Doc, Doc) {- ^ summary, detailed -} prettyProblem p = case p of TypeMismatch -> ( text "- type mismatch" , empty) WrongExact -> ( text "- wrong value" , empty) MissingSection name -> ( text "- missing section:" <+> text (Text.unpack name) , empty) UnusedSections names -> ( text "- unexpected sections:" <+> fsep (punctuate comma (map (text . Text.unpack) (toList names))) , empty) CustomProblem e -> ( text "-" <+> text (Text.unpack e) , empty) SubkeyProblem name e -> ( text "- problem in section:" <+> text (Text.unpack name) , prettyValueSpecMismatch e) NestedProblem e -> ( empty , prettyValueSpecMismatch e) ListElementProblem i e -> ( text "- problem in element:" <+> int i , 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 . simplifyValueSpecMismatch config-schema-1.3.0.0/src/Config/Schema/Spec.hs0000644000000000000000000003461707346545000017202 0ustar0000000000000000{-# Language ScopedTypeVariables, OverloadedStrings #-} {-| Module : Config.Schema.Spec Description : Operations for describing a configuration file format. Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com This module provides a set of types and operations for defining configuration file schemas. These specifications are can be consumed by "Config.Schema.Load" and "Config.Schema.Docs". This is the schema system used by the @glirc@ IRC client . For a significant example, visit the @Client.Configuration@ and @Client.Configuration.Colors@ modules. -} module Config.Schema.Spec ( -- * Specifying values -- $values ValueSpec , customSpec , namedSpec , exactSpec , HasSpec(..) -- ** Key-value mapping specifications -- $sections , sectionsSpec , assocSpec -- ** Number specifications -- $number , numberSpec , integerSpec , rationalSpec , naturalSpec , fractionalSpec , numSpec -- ** Text specifications -- $text , textSpec , stringSpec -- ** Atom specifications -- $atom , atomSpec , anyAtomSpec , yesOrNoSpec , trueOrFalseSpec -- ** List specifications -- $list , listSpec , oneOrList , nonemptySpec , oneOrNonemptySpec -- * Specifying sections -- $sectionsspec , SectionsSpec , reqSection , optSection , reqSection' , optSection' -- * Re-exports , Alt(..) ) where import Data.Bits (FiniteBits, isSigned, toIntegralSized, finiteBitSize) import Data.Functor.Alt (Alt(..)) import Data.Int import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty 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 (Value(..), Atom(..)) import Config.Number (Number, numberToInteger, numberToRational) ------------------------------------------------------------------------ -- 'ValueSpec' builders ------------------------------------------------------------------------ -- $values -- -- 'ValueSpec' allows you to define specifications that will match -- parsed config-value configuration files. 'ValueSpec' allows -- us to define the shape of configuration values that will match -- the specification as well as a way to process those matches. -- -- Below we have an example configuration record that can be matched -- from a configuration file. -- -- More documentation for defining key-value pairs is available below. -- -- This configuration file expects either a given username or allows -- the user to ask for a random username. The ('') operator allows -- us to combine two alternatives as seen below. The config-value -- language distinguishes between atoms like @random@ and strings like -- @"random"@ allowing unambiguous special cases to be added in addition -- to free-form text. -- -- @ -- {-\# Language RecordWildCards, OverloadedStrings, ApplicativeDo \#-} -- module Example where -- -- import "Config.Schema" -- import "Data.Functor.Alt" (('')) -- import "Data.Maybe" ('Data.Maybe.fromMaybe') -- import "Data.Text" ('Text') -- -- data Config = Config -- { userName :: UserName -- , retries :: 'Int' -- } -- -- data UserName = Random | Given 'Text' -- -- userNameSpec :: ValueSpec UserName -- userNameSpec = Random '<$' 'atomSpec' \"random\" -- '' Given '<$>' 'anySpec' -- matches string literals -- -- nameExample :: 'ValueSpec' Config -- nameExample = 'sectionsSpec' \"config\" '$' -- -- do userName <- 'reqSection'' \"username\" userNameSpec \"Configured user name\" -- -- retries <- 'Data.Maybe.fromMaybe' 3 -- '<$>' 'optSection' \"retries\" \"Number of attempts (default: 3)\" -- -- 'pure' Config{..} -- @ -- -- Examples: -- -- > username: random -- > retries: 5 -- > -- Generates: Config { userName = Random, retries = 5 } -- -- We can omit the retries: -- -- > username: random -- > -- Generates: Config { userName = Random, retries = 3 } -- -- We can specify a specific username as a string literal instead -- of using the atom @random@: -- -- > username: "me" -- > -- Generates: Config { userName = Given "me", retries = 3 } -- -- Sections can be reordered: -- -- > retries: 5 -- > username: random -- > -- Generates: Config { userName = Random, retries = 5 } -- | Class of value specifications without parameters. class HasSpec a where anySpec :: ValueSpec a 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 = 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 -- | 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)) -- | Match an exact value. This can be used to match a specific text -- literal number literal, atom, list of exact things, etc. exactSpec :: Value () -> ValueSpec () exactSpec = primValueSpec . ExactSpec ------------------------------------------------------------------------ -- $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 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 any integral number. numSpec :: Num a => ValueSpec a numSpec = fromInteger <$> integerSpec -- | Specification for matching any fractional number. -- -- @since 0.2.0.0 fractionalSpec :: Fractional a => ValueSpec a fractionalSpec = fromRational <$> rationalSpec -- | 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 ------------------------------------------------------------------------ -- $atom -- Specifications built to match atoms. -- | Primitive specification for matching a particular atom. atomSpec :: Text {- ^ atom -} -> ValueSpec () atomSpec t = () <$ primValueSpec (ExactSpec (Atom () (MkAtom t))) -- | Primitive specification for matching any atom. Matched atom is returned. anyAtomSpec :: ValueSpec Text anyAtomSpec = primValueSpec AtomSpec -- | Specification for using atoms @yes@ and @no@ to represent booleans 'True' -- and 'False' respectively yesOrNoSpec :: ValueSpec Bool 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" ------------------------------------------------------------------------ -- $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 {- ^ element specification -} -> ValueSpec (NonEmpty a) nonemptySpec s = customSpec "nonempty" (listSpec s) check where check xs = case NonEmpty.nonEmpty xs of Nothing -> Left "empty list" Just xxs -> Right xxs -- | Matches a single element or a non-empty list. -- -- @since 0.2.0.0 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 ------------------------------------------------------------------------ -- $sectionsspec -- Sections specifications allow you to define an unordered collection -- of required and optional sections using a convenient 'Applicative' -- do-notation syntax. -- -- Let's consider an example of a way to specify a name given a base -- and optional suffix. -- -- @ -- {-\# Language OverloadedStrings, ApplicativeDo \#-} -- module Example where -- -- import "Config.Schema" -- import "Data.Text" ('Text') -- -- nameExample :: 'ValueSpec' 'Text' -- nameExample = -- 'sectionsSpec' \"name\" '$' -- do x <- 'reqSection' \"base\" \"Base name\" -- y <- 'optSection' \"suffix\" \"Optional name suffix\" -- 'pure' ('maybe' x (x '<>') y) -- @ -- -- Example configuration components and their extracted values. -- -- > base: "VAR" -- > optional: "1" -- > -- Generates: VAR1 -- -- Order doesn't matter -- -- > optional: "1" -- > base: "VAR" -- > -- Generates: VAR1 -- -- Optional fields can be omitted -- -- > base: "VAR" -- > -- Generates: VAR -- -- Unexpected sections will generate errors to help detect typos -- -- > base: "VAR" -- > extra: 0 -- > -- Failure due to unexpected extra section -- -- All required sections must appear for successful match -- -- > optional: "1" -- > -- Failure due to missing required section -- | Specification for a required section with an implicit value specification. reqSection :: HasSpec a => Text {- ^ section name -} -> Text {- ^ description -} -> SectionsSpec a reqSection n = reqSection' n anySpec -- | Specification for a required section with an explicit value specification. reqSection' :: Text {- ^ section name -} -> ValueSpec a {- ^ value specification -} -> Text {- ^ description -} -> SectionsSpec a reqSection' n w i = primSectionsSpec (ReqSection n i w) -- | Specification for an optional section with an implicit value specification. optSection :: HasSpec a => Text {- ^ section name -} -> Text {- ^ description -} -> SectionsSpec (Maybe a) optSection n = optSection' n anySpec -- | Specification for an optional section with an explicit value specification. optSection' :: Text {- ^ section name -} -> ValueSpec a {- ^ value specification -} -> Text {- ^ description -} -> SectionsSpec (Maybe a) optSection' n w i = primSectionsSpec (OptSection n i w) config-schema-1.3.0.0/src/Config/Schema/Types.hs0000644000000000000000000001641507346545000017410 0ustar0000000000000000{-# Language CPP, KindSignatures, RankNTypes, GADTs, DeriveTraversable, GeneralizedNewtypeDeriving #-} {-| Module : Config.Schema.Types Description : Types for describing a configuration file format. Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com This module defines the syntax of value specifications. Specifications can be defined using "Config.Schema.Spec" and can be consumed with "Config.Schema.Load" and "Config.Schema.Doc". This module defines high-level 'ValueSpec' and @SectionsSpec@ types that are intended to be used by normal library users. This types are implemented in terms of primitive 'PrimValueSpec' and 'PrimSectionSpec' types. These primitives are what consumers of specifications will need to use. -} module Config.Schema.Types ( -- * Value specification ValueSpec , PrimValueSpec(..) , primValueSpec , runValueSpec , runValueSpec_ -- * Unordered section-value pairs specification , SectionsSpec , PrimSectionSpec(..) , primSectionsSpec , runSections , runSections_ ) where import Config (Value) import Config.Number (Number) import Control.Applicative (Const(..)) import Control.Applicative.Free (Ap, liftAp, runAp, runAp_) import Data.Functor.Alt (Alt(..)) import Data.Functor.Coyoneda (Coyoneda(..), liftCoyoneda, lowerCoyoneda, hoistCoyoneda) import Data.List.NonEmpty (NonEmpty) import Data.Semigroup.Foldable (asum1, foldMap1) import Data.Text (Text) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup) #endif ------------------------------------------------------------------------ -- Specifications for values ------------------------------------------------------------------------ -- | The primitive specification descriptions for values. Specifications -- built from these primitive cases are found in 'ValueSpec'. data PrimValueSpec :: * -> * where -- | Matches any string literal TextSpec :: PrimValueSpec Text -- | Matches numbers NumberSpec :: PrimValueSpec Number -- | Matches any atom AtomSpec :: PrimValueSpec Text -- | Matches a list of the underlying specification ListSpec :: ValueSpec a -> PrimValueSpec [a] -- | Documentation identifier and sections specification SectionsSpec :: Text -> SectionsSpec a -> PrimValueSpec a -- | Matches an arbitrary list of sections. Similar to 'SectionsSpec' -- except that that the section names are user-defined. AssocSpec :: ValueSpec a -> PrimValueSpec [(Text,a)] -- | Documentation text and underlying specification. This specification -- will match values where the underlying specification returns a -- 'Right' value. Otherwise a 'Left' should contain a short failure -- explanation. CustomSpec :: Text -> ValueSpec (Either Text a) -> PrimValueSpec a -- | Label used to hide complex specifications in documentation. NamedSpec :: Text -> ValueSpec a -> PrimValueSpec a -- | Specific value to be matched ExactSpec :: Value () -> PrimValueSpec () -- | Non-empty disjunction of value specifications. This type is the primary -- way to specify expected values. -- -- Multiple specifications can be combined using this type's 'Alt' instance. -- -- To create 'ValueSpec' values see "Config.Schema.Spec" newtype ValueSpec a = MkValueSpec { unValueSpec :: NonEmpty (Coyoneda PrimValueSpec a) } deriving (Functor) -- | Lift a primitive value specification to 'ValueSpec'. -- -- @since 0.2.0.0 primValueSpec :: PrimValueSpec a -> ValueSpec a primValueSpec = MkValueSpec . pure . liftCoyoneda -- | Given an interpretation of a primitive value specification, extract a list of -- the possible interpretations of a disjunction of value specifications. Each of -- these primitive interpretations will be combined using the provided 'Alt' instance. runValueSpec :: Alt f => (forall x. PrimValueSpec x -> f x) -> ValueSpec a -> f a runValueSpec f = asum1 . fmap (runCoyoneda f) . unValueSpec -- | Given an interpretation of a primitive value specification, extract a list of -- the possible interpretations of a disjunction of value specifications. Each of -- these primitive interpretations will be combined using the provided 'Semigroup' instance. runValueSpec_ :: Semigroup m => (forall x. PrimValueSpec x -> m) -> ValueSpec a -> m runValueSpec_ f = foldMap1 (runCoyoneda_ f) . unValueSpec -- Helper for transforming the underlying type @f@ to one supporting a 'Functor' -- instance before lowering. runCoyoneda :: Functor g => (forall a. f a -> g a) -> Coyoneda f b -> g b runCoyoneda f = lowerCoyoneda . hoistCoyoneda f -- Helper for extracting the the value stored in a 'Coyoneda' while forgetting its -- type index. runCoyoneda_ :: (forall a. f a -> m) -> Coyoneda f b -> m runCoyoneda_ f = getConst . runCoyoneda (Const . f) -- | Left-biased choice between two specifications instance Alt ValueSpec where MkValueSpec x MkValueSpec y = MkValueSpec (x y) ------------------------------------------------------------------------ -- Specifications for sections ------------------------------------------------------------------------ -- | Specifications for single configuration sections. -- -- The fields are section name, documentation text, value specification. -- Use 'ReqSection' for required key-value pairs and 'OptSection' for -- optional ones. data PrimSectionSpec :: * -> * where -- | Required section: Name, Documentation, Specification ReqSection :: Text -> Text -> ValueSpec a -> PrimSectionSpec a -- | Optional section: Name, Documentation, Specification OptSection :: Text -> Text -> ValueSpec a -> PrimSectionSpec (Maybe a) -- | A list of section specifications used to process a whole group of -- key-value pairs. Multiple section specifications can be combined -- using this type's 'Applicative' instance. -- -- To create @SectionsSpec@ values see "Config.Schema.Spec" newtype SectionsSpec a = MkSectionsSpec (Ap PrimSectionSpec a) deriving (Functor, Applicative) -- | Lift a single specification into a list of specifications. -- -- @since 0.2.0.0 primSectionsSpec :: PrimSectionSpec a -> SectionsSpec a primSectionsSpec = MkSectionsSpec . 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. PrimSectionSpec x -> f x) -> SectionsSpec a -> f a runSections f (MkSectionsSpec 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. PrimSectionSpec x -> m) -> SectionsSpec a -> m runSections_ f (MkSectionsSpec s) = runAp_ f s config-schema-1.3.0.0/tests/0000755000000000000000000000000007346545000013707 5ustar0000000000000000config-schema-1.3.0.0/tests/Main.hs0000644000000000000000000000641207346545000015132 0ustar0000000000000000{-# Language OverloadedStrings #-} {-| Module : Main Description : Unit tests for config-schema Copyright : (c) Eric Mertens, 2017 License : ISC Maintainer : emertens@gmail.com -} module Main (main) where import Config import Config.Schema import Control.Applicative import Data.Foldable import Data.Text (Text) import qualified Data.Text as Text -- tests that are expected to pass. -- -- The input sources are a list of lists of lines. Each outer list -- element contains a list of lines representing a complete input -- source. Each of these variations must pass the test. test :: Show a => Eq a => ValueSpec a {- ^ specification to match -} -> a {- ^ expected output -} -> [[Text]] {- ^ inputs sources -} -> IO () test spec expected txtss = for_ txtss $ \txts -> case parse (Text.unlines txts) of Left e -> fail (show e) Right v -> case loadValue spec v of Left e -> fail (show e) Right x | x == expected -> return () | otherwise -> fail ("Got " ++ show x ++ " but expected " ++ show expected) main :: IO () main = sequenceA_ [ test anySpec ("Hello world"::Text) [["\"Hello world\""] ,["\"H\\101l\\&l\\o157 \\" ," \\w\\x6frld\""] ] , test anySpec (1234::Integer) [["1234"] ,["1234.0"] ] , test anySpec (0.65::Rational) [["0.65e0"] ,["65e-2"] ,["6.5e-1"] ,["0.65"] ] , test anyAtomSpec "default" [["default"]] , test (atomSpec "testing-1-2-3") () [["testing-1-2-3"]] , test (listSpec anySpec) ([]::[Integer]) [["[]"] ,["[ ]"]] , test (listSpec anyAtomSpec) ["ḿyatoḿ"] [["[ḿyatoḿ]"] ,[" [ ḿyatoḿ ] "] ,["* ḿyatoḿ"] ] , test anySpec [1,2,3::Int] [["[1,2,3]"] ,["[1,2,3,]"] ,["* 1" ,"* 2" ,"* 3"] ] , test (listSpec anySpec) [[1,2],[3,4::Int]] [["[[1,2,],[3,4]]"] ,["*[1,2]" ,"*[3,4]"] ,["**1" ," *2" ,"* *3" ," *4" ] ] , test (assocSpec anySpec) ([]::[(Text,Int)]) [["{}"] ,["{ }"] ] , test (assocSpec anySpec) [("k1",10::Int), ("k2",20)] [["{k1: 10, k2: 20}"] ,["{k1: 10, k2: 20,}"] ,["k1 : 10" ,"k2: 20"] ] , test anySpec [ Left (1::Int), Right ("two"::Text) ] [["[1, \"two\"]"] ,["* 1" ,"* \"two\""] ] , test (sectionsSpec "test" (liftA2 (,) (reqSection "k1" "") (reqSection "k2" ""))) (10 :: Int, 20 :: Int) [["k1: 10" ,"k2: 20"] ,["k2: 20" ,"k1: 10"] ] , test (sectionsSpec "test" (liftA2 (,) (optSection "k1" "") (reqSection "k2" ""))) (Just 10 :: Maybe Int, 20 :: Int) [["k1: 10" ,"k2: 20"] ,["k2: 20" ,"k1: 10"] ] , test (sectionsSpec "test" (liftA2 (,) (optSection "k1" "") (reqSection "k2" ""))) (Nothing :: Maybe Int, 20 :: Int) [["k2: 20"] ,["{k2: 20}"] ] -- This isn't a good idea, but it currently works , test (sectionsSpec "test" (liftA2 (,) (reqSection "k1" "") (reqSection "k1" ""))) ("first"::Text, 50::Int) [["k1: \"first\"" ,"k1: 50"] ] , test (sectionsSpec "test" (pure ())) () [["{}"] ] ]