config-schema-0.5.0.0/0000755000000000000000000000000013114301146012535 5ustar0000000000000000config-schema-0.5.0.0/ChangeLog.md0000644000000000000000000000241413114301146014707 0ustar0000000000000000# Revision history for config-schema ## 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-0.5.0.0/config-schema.cabal0000644000000000000000000000430013114301146016221 0ustar0000000000000000name: config-schema version: 0.5.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. 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 maintainer: emertens@gmail.com copyright: Eric Mertens 2017 category: Language build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10 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 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.Spec build-depends: base >=4.8 && <4.11, config-value >=0.6 && <0.7, containers >=0.5 && <0.6, free >=4.12 && <4.13, kan-extensions >=5.0.2 && <5.1, pretty >=1.1.2 && <1.2, semigroupoids >=5.1 && <5.3, 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 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 flag use-semigroups default: False manual: False config-schema-0.5.0.0/LICENSE0000644000000000000000000000133213114301146013541 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-0.5.0.0/README.md0000644000000000000000000000577013114301146014025 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 :: ValueSpecs 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 :: ValueSpecs Text kidSpec = sectionsSpec "kid" (reqSection "name" "Kid's name") -- | Matches the 'yes' and 'no' atoms yesOrNo :: ValueSpecs 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-0.5.0.0/Setup.hs0000644000000000000000000000005613114301146014172 0ustar0000000000000000import Distribution.Simple main = defaultMain config-schema-0.5.0.0/src/0000755000000000000000000000000013114301146013324 5ustar0000000000000000config-schema-0.5.0.0/src/Config/0000755000000000000000000000000013114301146014531 5ustar0000000000000000config-schema-0.5.0.0/src/Config/Schema.hs0000644000000000000000000000175313114301146016273 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-0.5.0.0/src/Config/Schema/0000755000000000000000000000000013114301146015731 5ustar0000000000000000config-schema-0.5.0.0/src/Config/Schema/Docs.hs0000644000000000000000000001433013114301146017156 0ustar0000000000000000{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-} {-| 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 :: ValueSpecs (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 Data.Monoid (Monoid(..)) 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 Config.Schema.Spec -- | Default documentation generator. generateDocs :: ValueSpecs 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 runValueSpecs_ (pure . SomeSpec) spec of -- single, top-level sections spec SomeSpec (SectionSpecs 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 :: ValueSpec 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 -> SectionSpecs 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 :: SectionSpec 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 -} -> ValueSpecs a -> DocBuilder Doc valuesDoc nested = fmap (disjunction nested) . sequenceA . runValueSpecs_ (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 :: ValueSpec a -> DocBuilder Doc valueDoc w = case w of TextSpec -> pure "text" IntegerSpec -> pure "integer" RationalSpec -> pure "number" AtomSpec a -> pure ("`" <> txt a <> "`") AnyAtomSpec -> pure "atom" SectionSpecs 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 -- | 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-0.5.0.0/src/Config/Schema/Load.hs0000644000000000000000000002315113114301146017146 0ustar0000000000000000{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, 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 , SchemaError(..) , LoadError(..) , Problem(..) ) where import Control.Exception (Exception(..), throwIO) import Control.Monad (zipWithM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), runStateT) import Control.Monad.Trans.Except (Except, runExcept, throwE) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local) import Data.Semigroup.Foldable (asum1) import Data.Functor.Alt (Alt(())) import Data.Monoid ((<>)) import Data.Ratio (numerator, denominator) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Config import Config.Schema.Spec -- | Match a 'Value' against a 'ValueSpecs' and return either -- the interpretation of that value or the list of errors -- encountered. loadValue :: ValueSpecs a {- ^ specification -} -> Value p {- ^ value -} -> Either (NonEmpty (LoadError p)) a {- ^ errors or decoded value -} loadValue spec val = runLoad (getValue spec val) -- | Read a configuration file, parse it, and validate it according -- to the given specification. -- -- Throws 'IOError', 'ParseError', or 'SchemaError' loadValueFromFile :: ValueSpecs a {- ^ specification -} -> FilePath {- ^ filename -} -> IO a loadValueFromFile spec path = do txt <- Text.readFile path val <- either throwIO return (parse txt) either (throwIO . SchemaError) return (loadValue spec val) -- | Newtype wrapper for schema load errors. newtype SchemaError = SchemaError (NonEmpty (LoadError Position)) deriving Show -- | Custom 'displayException' implementation instance Exception SchemaError where displayException (SchemaError e) = foldr showLoadError "" e where showLoadError (LoadError pos path problem) = shows (posLine pos) . showChar ':' . shows (posColumn pos) . showString ": " . foldr (\x xs -> showString (Text.unpack x) . showChar ':' . xs) id path . showChar ' ' . showProblem problem . showChar '\n' showProblem p = case p of MissingSection x -> showString "missing required section `" . showString (Text.unpack x) . showChar '`' UnusedSection x -> showString "unused section `" . showString (Text.unpack x) . showChar '`' SpecMismatch x -> showString "expected " . showString (Text.unpack x) getSection :: p -> SectionSpec a -> StateT [Section p] (Load p) a getSection pos (ReqSection k _ w) = do v <- StateT (lookupSection pos k) lift (scope k (getValue w v)) getSection pos (OptSection k _ w) = do mb <- optional1 (StateT (lookupSection pos k)) lift (traverse (scope k . getValue w) mb) getSections :: p -> SectionSpecs a -> [Section p] -> Load p a getSections pos spec xs = do (a,leftovers) <- runStateT (runSections (getSection pos) spec) xs case NonEmpty.nonEmpty leftovers of Nothing -> return a Just ss -> asum1 (fmap (\s -> loadFail (sectionAnn s) (UnusedSection (sectionName s))) ss) getValue :: ValueSpecs a -> Value p -> Load p a getValue s v = runValueSpecs (getValue1 v) s -- | Match a primitive value specification against a single value. getValue1 :: Value p -> ValueSpec a -> Load p a getValue1 (Text _ t) TextSpec = pure t getValue1 (Number _ _ n) IntegerSpec = pure n getValue1 (Floating _ a b) IntegerSpec | Just i <- floatingToInteger a b = pure i getValue1 (Number _ _ n) RationalSpec = pure (fromInteger n) getValue1 (Floating _ a b) RationalSpec = pure (floatingToRational a b) getValue1 (List _ xs) (ListSpec w) = getList w xs getValue1 (Atom _ b) AnyAtomSpec = pure (atomName b) getValue1 (Atom _ b) (AtomSpec a) | a == atomName b = pure () getValue1 (Sections p s) (SectionSpecs _ w) = getSections p w s getValue1 (Sections _ s) (AssocSpec w) = getAssoc w s getValue1 v (NamedSpec _ w) = getValue w v getValue1 v (CustomSpec l w) = getCustom l w v getValue1 v TextSpec = loadFail (valueAnn v) (SpecMismatch "text") getValue1 v IntegerSpec = loadFail (valueAnn v) (SpecMismatch "integer") getValue1 v RationalSpec = loadFail (valueAnn v) (SpecMismatch "number") getValue1 v ListSpec{} = loadFail (valueAnn v) (SpecMismatch "list") getValue1 v AnyAtomSpec = loadFail (valueAnn v) (SpecMismatch "atom") getValue1 v (AtomSpec a) = loadFail (valueAnn v) (SpecMismatch ("`" <> a <> "`")) getValue1 v (SectionSpecs l _) = loadFail (valueAnn v) (SpecMismatch l) getValue1 v AssocSpec{} = loadFail (valueAnn v) (SpecMismatch "association list") -- | 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 :: ValueSpecs a -> [Value p] -> Load p [a] getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [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 :: ValueSpecs a -> [Section p] -> Load p [(Text,a)] getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> scope k (getValue w v) -- | Match a value against its specification. If 'Just' is matched -- return the value. If 'Nothing is matched, report an error. getCustom :: Text {- ^ label -} -> ValueSpecs (Maybe a) {- ^ specification -} -> Value p {- ^ value -} -> Load p a getCustom l w v = do x <- getValue w v case x of Nothing -> loadFail (valueAnn v) (SpecMismatch l) Just y -> pure y -- | Extract a section from a list of sections by name. lookupSection :: p {- ^ starting position of sections -} -> Text {- ^ section name -} -> [Section p] {- ^ available sections -} -> Load p (Value p, [Section p]) {- ^ found value and remaining sections -} lookupSection pos key [] = loadFail pos (MissingSection key) lookupSection pos key (s@(Section _ k v):xs) | key == k = pure (v, xs) | otherwise = do (v',xs') <- lookupSection pos key xs return (v',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 ------------------------------------------------------------------------ -- Error reporting type ------------------------------------------------------------------------ -- | 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 p a = MkLoad { unLoad :: ReaderT [Text] (Except (NonEmpty (LoadError p))) a } deriving (Functor, Applicative, Monad) instance Alt (Load p) 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. data LoadError p = LoadError p [Text] Problem -- ^ position, path, problem deriving (Read, Show) -- | Run the Load computation until it produces a result or terminates -- with a list of errors. runLoad :: Load p a -> Either (NonEmpty (LoadError p)) a runLoad = runExcept . flip runReaderT [] . unLoad -- | Problems that can be encountered when matching a 'Value' against a 'ValueSpecs'. data Problem = MissingSection Text -- ^ missing section name | UnusedSection Text -- ^ unused section names | SpecMismatch Text -- ^ failed specification name deriving (Eq, Ord, Read, Show) -- | Push a new key onto the stack of nested fields. scope :: Text -> Load p a -> Load p a scope key (MkLoad m) = MkLoad (local (key:) m) -- | Abort value specification matching with the given error. loadFail :: p -> Problem -> Load p a loadFail pos cause = MkLoad $ do path <- ask lift (throwE (pure (LoadError pos (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 config-schema-0.5.0.0/src/Config/Schema/Spec.hs0000644000000000000000000003273113114301146017165 0ustar0000000000000000{-# Language FlexibleInstances, RankNTypes, GADTs, KindSignatures #-} {-# Language DeriveFunctor, GeneralizedNewtypeDeriving, OverloadedStrings #-} {-| Module : Config.Schema.Spec Description : Types and 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 schemas can be built up using 'Applicative' operations. These specifications are suitable for 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 sections SectionSpecs , reqSection , optSection , reqSection' , optSection' -- * Specifying values , ValueSpecs , Spec(..) , sectionsSpec , assocSpec , atomSpec , anyAtomSpec , listSpec , customSpec , namedSpec -- * Derived specifications , oneOrList , yesOrNoSpec , stringSpec , numSpec , fractionalSpec , nonemptySpec , oneOrNonemptySpec -- * Executing specifications , runSections , runSections_ , runValueSpecs , runValueSpecs_ -- * Primitive specifications , SectionSpec(..) , liftSectionSpec , ValueSpec(..) , liftValueSpec ) where import Control.Applicative (Const(..)) import Control.Applicative.Free (Ap, runAp, runAp_, liftAp) import Data.Bits (Bits, toIntegralSized) import Data.Functor.Coyoneda (Coyoneda(..), liftCoyoneda, lowerCoyoneda, hoistCoyoneda) import Data.Functor.Alt (Alt(..)) import Data.Int import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup (Semigroup) import Data.Semigroup.Foldable (asum1, foldMap1) import Data.Text (Text) import qualified Data.Text as Text import Data.Word ------------------------------------------------------------------------ -- 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 SectionSpec :: * -> * where -- | Required section: Name, Documentation, Specification ReqSection :: Text -> Text -> ValueSpecs a -> SectionSpec a -- | Optional section: Name, Documentation, Specification OptSection :: Text -> Text -> ValueSpecs a -> SectionSpec (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. newtype SectionSpecs a = MkSectionSpecs (Ap SectionSpec a) deriving (Functor, Applicative) -- | Lift a single specification into a list of specifications. -- -- @since 0.2.0.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 ------------------------------------------------------------------------ -- 'SectionSpecs' builders ------------------------------------------------------------------------ -- | Specification for a required section with an implicit value specification. reqSection :: Spec a => Text {- ^ section name -} -> Text {- ^ description -} -> SectionSpecs a reqSection n i = liftSectionSpec (ReqSection n i valuesSpec) -- | Specification for a required section with an explicit value specification. reqSection' :: Text {- ^ section name -} -> ValueSpecs a {- ^ value specification -} -> Text {- ^ description -} -> SectionSpecs a reqSection' n w i = liftSectionSpec (ReqSection n i w) -- | Specification for an optional section with an implicit value specification. optSection :: Spec a => Text {- ^ section name -} -> Text {- ^ description -} -> SectionSpecs (Maybe a) optSection n i = liftSectionSpec (OptSection n i valuesSpec) -- | Specification for an optional section with an explicit value specification. optSection' :: Text {- ^ section name -} -> ValueSpecs a {- ^ value specification -} -> Text {- ^ description -} -> SectionSpecs (Maybe a) optSection' n w i = liftSectionSpec (OptSection n i w) ------------------------------------------------------------------------ -- Specifications for values ------------------------------------------------------------------------ -- | The primitive specification descriptions for values. Specifications -- built from these primitive cases are found in 'ValueSpecs'. data ValueSpec :: * -> * where -- | Matches any string literal TextSpec :: ValueSpec Text -- | Matches integral numbers IntegerSpec :: ValueSpec Integer -- | Matches any number RationalSpec :: ValueSpec Rational -- | Matches any atom AnyAtomSpec :: ValueSpec Text -- | Specific atom to be matched AtomSpec :: Text -> ValueSpec () -- | Matches a list of the underlying specification ListSpec :: ValueSpecs a -> ValueSpec [a] -- | Documentation identifier and section specification SectionSpecs :: Text -> SectionSpecs a -> ValueSpec a -- | Matches an arbitrary list of sections. Similar to 'SectionSpec' -- except that that the section names are user-defined. AssocSpec :: ValueSpecs a -> ValueSpec [(Text,a)] -- | Documentation text, underlying specification CustomSpec :: Text -> ValueSpecs (Maybe a) -> ValueSpec a -- | Label used to hide complicated specs in documentation NamedSpec :: Text -> ValueSpecs a -> ValueSpec a -- | 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 :: NonEmpty (Coyoneda ValueSpec a) } deriving (Functor) -- | Left-biased choice between two specifications instance Alt ValueSpecs where MkValueSpecs x MkValueSpecs y = MkValueSpecs (x y) -- | 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. runValueSpecs :: Alt f => (forall x. ValueSpec x -> f x) -> ValueSpecs a -> f a runValueSpecs f = asum1 . fmap (runCoyoneda f) . unValueSpecs -- | 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. runValueSpecs_ :: Semigroup m => (forall x. ValueSpec x -> m) -> ValueSpecs a -> m runValueSpecs_ f = foldMap1 (runCoyoneda_ f) . unValueSpecs -- 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) -- | Lift a primitive value specification to 'ValueSpecs'. -- -- @since 0.2.0.0 liftValueSpec :: ValueSpec a -> ValueSpecs a liftValueSpec = MkValueSpecs . pure . liftCoyoneda ------------------------------------------------------------------------ -- 'ValueSpecs' builders ------------------------------------------------------------------------ -- | Class of value specifications that don't require arguments. class Spec a where valuesSpec :: ValueSpecs a instance Spec Text where valuesSpec = liftValueSpec TextSpec instance Spec Integer where valuesSpec = liftValueSpec IntegerSpec instance Spec Rational where valuesSpec = liftValueSpec RationalSpec 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 instance Spec Int where valuesSpec = sizedBitsSpec "machine-bit signed" instance Spec Int8 where valuesSpec = sizedBitsSpec "8-bit signed" instance Spec Int16 where valuesSpec = sizedBitsSpec "16-bit signed" instance Spec Int32 where valuesSpec = sizedBitsSpec "32-bit signed" instance Spec Int64 where valuesSpec = sizedBitsSpec "64-bit signed" instance Spec Word where valuesSpec = sizedBitsSpec "machine-bit unsigned" instance Spec Word8 where valuesSpec = sizedBitsSpec "8-bit unsigned" instance Spec Word16 where valuesSpec = sizedBitsSpec "16-bit unsigned" instance Spec Word32 where valuesSpec = sizedBitsSpec "32-bit unsigned" instance Spec Word64 where valuesSpec = sizedBitsSpec "64-bit unsigned" sizedBitsSpec :: (Integral a, Bits a) => Text -> ValueSpecs a sizedBitsSpec name = customSpec name (liftValueSpec IntegerSpec) toIntegralSized -- | Specification for matching a particular atom. atomSpec :: Text -> ValueSpecs () atomSpec = liftValueSpec . AtomSpec -- | Specification for matching any atom. Matched atom is returned. anyAtomSpec :: ValueSpecs Text anyAtomSpec = liftValueSpec AnyAtomSpec -- | Specification for matching any text as a 'String' stringSpec :: ValueSpecs String stringSpec = Text.unpack <$> valuesSpec -- | Specification for matching any integral number. numSpec :: Num a => ValueSpecs a numSpec = fromInteger <$> valuesSpec -- | Specification for matching any fractional number. -- -- @since 0.2.0.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 = liftValueSpec . 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 -} -> SectionSpecs a {- ^ underlying specification -} -> ValueSpecs a sectionsSpec i s = liftValueSpec (SectionSpecs 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 :: ValueSpecs a {- ^ underlying specification -} -> ValueSpecs [(Text,a)] assocSpec = liftValueSpec . 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 -} -> ValueSpecs a {- ^ underlying specification -} -> ValueSpecs a namedSpec n s = liftValueSpec (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 :: ValueSpecs a -> ValueSpecs [a] oneOrList s = pure <$> s listSpec 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 -> ValueSpecs a -> (a -> Maybe b) -> ValueSpecs b customSpec lbl w f = liftValueSpec (CustomSpec lbl (f <$> w)) -- | Specification for using @yes@ and @no@ to represent booleans 'True' -- and 'False' respectively yesOrNoSpec :: ValueSpecs Bool yesOrNoSpec = True <$ atomSpec (Text.pack "yes") False <$ atomSpec (Text.pack "no") -- | Matches a non-empty list. -- -- @since 0.2.0.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.2.0.0 oneOrNonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a) oneOrNonemptySpec s = pure <$> s nonemptySpec s config-schema-0.5.0.0/tests/0000755000000000000000000000000013114301146013677 5ustar0000000000000000config-schema-0.5.0.0/tests/Main.hs0000644000000000000000000000645013114301146015124 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 => ValueSpecs 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 valuesSpec ("Hello world"::Text) [["\"Hello world\""] ,["\"H\\101l\\&l\\o157 \\" ," \\w\\x6frld\""] ] , test valuesSpec (1234::Integer) [["1234"] ,["1234.0"] ] , test valuesSpec (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 valuesSpec) ([]::[Integer]) [["[]"] ,["[ ]"]] , test (listSpec anyAtomSpec) ["ḿyatoḿ"] [["[ḿyatoḿ]"] ,[" [ ḿyatoḿ ] "] ,["* ḿyatoḿ"] ] , test valuesSpec [1,2,3::Int] [["[1,2,3]"] ,["[1,2,3,]"] ,["* 1" ,"* 2" ,"* 3"] ] , test (listSpec valuesSpec) [[1,2],[3,4::Int]] [["[[1,2,],[3,4]]"] ,["*[1,2]" ,"*[3,4]"] ,["**1" ," *2" ,"* *3" ," *4" ] ] , test (assocSpec valuesSpec) ([]::[(Text,Int)]) [["{}"] ,["{ }"] ] , test (assocSpec valuesSpec) [("k1",10::Int), ("k2",20)] [["{k1: 10, k2: 20}"] ,["{k1: 10, k2: 20,}"] ,["k1 : 10" ,"k2: 20"] ] , test valuesSpec [ 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 ())) () [["{}"] ] ]