diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for config-schema + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,88 @@ +config-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) + +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 qualified Data.Text.IO as Text +import Data.Text (Text) +import Data.Monoid ((<>)) +import Data.Functor.Alt (()) + +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 +Right exampleValue = parse exampleFile + +exampleSpec :: ValueSpecs Text +exampleSpec = sectionsSpec "" $ + do name <- reqSection "name" "Full name" + age <- reqSection "age" "Age of user" + happy <- optSection' "happy" "Current happiness status" yesOrNo + kids <- reqSection' "kids" "All children" (oneOrList kidSpec) + + 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 = Text.putStr (generateDocs exampleSpec) +-- *Example> printDoc +-- 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 [LoadError] Text +example = loadValue exampleSpec exampleValue +-- *Example> exampleVal +-- Right "Johny Appleseed is 99 years old and has kids Bob, Tom and is happy" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/config-schema.cabal b/config-schema.cabal new file mode 100644 --- /dev/null +++ b/config-schema.cabal @@ -0,0 +1,37 @@ +name: config-schema +version: 0.1.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 + +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.9 && <4.11, + text >=1.2 && <1.3, + free >=4.12 && <4.13, + kan-extensions >=5.0 && <5.1, + semigroupoids >=5.2 && <5.3, + transformers >=0.5 && <0.6, + config-value >=0.5 && <0.6, + containers >=0.5 && <0.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Config/Schema.hs b/src/Config/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema.hs @@ -0,0 +1,27 @@ +{-| +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. + +"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 diff --git a/src/Config/Schema/Docs.hs b/src/Config/Schema/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema/Docs.hs @@ -0,0 +1,128 @@ +{-# Language 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 + +-- Configuration file fields: +-- username: REQUIRED text +-- Name used to login +-- attempts: integer +-- Number of login attempts +@ + +-} +module Config.Schema.Docs + ( generateDocs + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) +import qualified Data.Text as Text + +import Config.Schema.Spec + +-- | Default documentation generator. This generator is specifically +-- for configuration specifications where the top-level specification +-- is named with the empty string (@""@). +generateDocs :: ValueSpecs a -> Text +generateDocs spec = Text.unlines + ("Configuration file fields:" + : map (" " <>) top + ++ concatMap sectionLines (Map.toList m')) + + where + topname = "" + Just top = Map.lookup topname m + DocBuilder (m,"") = valuesDoc spec + m' = Map.delete topname m + + sectionLines :: (Text, [Text]) -> [Text] + sectionLines (name, fields) + = "" + : name + : map (" "<>) fields + + +-- | 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 Text +sectionsDoc l spec = emitDoc l =<< runSections_ sectionDoc spec + + +-- | Compute the documentation lines for a single key-value pair. +sectionDoc :: SectionSpec a -> DocBuilder [Text] +sectionDoc s = + case s of + ReqSection name desc w -> aux "REQUIRED " name desc <$> valuesDoc w + OptSection name desc w -> aux "" name desc <$> valuesDoc w + where + aux req name desc val = + (name <> ": " <> req <> val) + : if Text.null desc then [] else [" " <> desc] + + +-- | Compute the documentation line for a particular value specification. +-- Any sections contained in the specification will be stored in the +-- sections map. +valuesDoc :: ValueSpecs a -> DocBuilder Text +valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ valueDoc + + +-- | Combine a list of text with the word @or@. +disjunction :: NonEmpty Text -> Text +disjunction = Text.intercalate " or " . NonEmpty.toList + + +-- | Compute the documentation fragment for an individual value specification. +valueDoc :: ValueSpec a -> DocBuilder Text +valueDoc w = + case w of + TextSpec -> return "text" + IntegerSpec -> return "integer" + RationalSpec -> return "number" + AtomSpec a -> return ("`" <> a <> "`") + AnyAtomSpec -> return "atom" + SectionSpecs l s -> sectionsDoc l s + NamedSpec l s -> emitDoc l . pure =<< valuesDoc s + CustomSpec l w' -> ((l <> " ") <>) <$> valuesDoc w' + ListSpec ws -> ("list of " <>) <$> valuesDoc ws + + +-- | A writer-like type. A mapping of section names and documentation +-- lines is accumulated. +newtype DocBuilder a = DocBuilder (Map Text [Text], a) + deriving (Functor, Applicative, Monad, Monoid, Show) + + +-- | Given a section name and section body, store the body +-- in the map of sections and return the section name. +emitDoc :: + Text {- ^ section name -} -> + [Text] {- ^ section body -} -> + DocBuilder Text +emitDoc l xs = DocBuilder (Map.singleton l xs, l) diff --git a/src/Config/Schema/Load.hs b/src/Config/Schema/Load.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema/Load.hs @@ -0,0 +1,174 @@ +{-# 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 + + -- * Errors + , LoadError(..) + , Problem(..) + ) where + +import Control.Applicative (Alternative, optional) +import Control.Monad (MonadPlus, unless, zipWithM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (StateT(..), runStateT) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Foldable (asum) +import Data.Monoid ((<>)) +import Data.Ratio (numerator, denominator) +import Data.Text (Text) +import qualified Data.Text 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 {- ^ value -} -> + Either [LoadError] a {- ^ error or decoded value -} +loadValue spec val = runLoad (getValue spec val) + + +getSection :: SectionSpec a -> StateT [Section] Load a +getSection (ReqSection k _ w) = + do v <- StateT (lookupSection k) + lift (scope k (getValue w v)) +getSection (OptSection k _ w) = + do mb <- optional (StateT (lookupSection k)) + lift (traverse (scope k . getValue w) mb) + + +getSections :: SectionSpecs a -> [Section] -> Load a +getSections p xs = + do (a,leftover) <- runStateT (runSections getSection p) xs + unless (null leftover) (loadFail (UnusedSections (map sectionName leftover))) + return a + + +getValue :: ValueSpecs a -> Value -> Load a +getValue s v = asum (runValueSpecs (getValue1 v) s) + + +-- | Match a primitive value specification against a single value. +getValue1 :: Value -> ValueSpec a -> Load 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 s) (SectionSpecs _ w) = getSections w s +getValue1 v (NamedSpec _ w) = getValue w v +getValue1 v (CustomSpec l w) = getCustom l w v + +getValue1 _ TextSpec = loadFail (SpecMismatch "text") +getValue1 _ IntegerSpec = loadFail (SpecMismatch "integer") +getValue1 _ RationalSpec = loadFail (SpecMismatch "rational") +getValue1 _ ListSpec{} = loadFail (SpecMismatch "list") +getValue1 _ AnyAtomSpec = loadFail (SpecMismatch "atom") +getValue1 _ (AtomSpec a) = loadFail (SpecMismatch ("`" <> a <> "`")) +getValue1 _ (SectionSpecs l _) = loadFail (SpecMismatch l) + + +-- | 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] -> Load [a] +getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [1::Int ..] + + +-- | 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 {- ^ value -} -> + Load a +getCustom l w v = + do x <- getValue w v + case x of + Nothing -> loadFail (SpecMismatch l) + Just y -> pure y + + +-- | Extract a section from a list of sections by name. +lookupSection :: + Text {- ^ section name -} -> + [Section] {- ^ available sections -} -> + Load (Value, [Section]) {- ^ found value and remaining sections -} +lookupSection key [] = loadFail (MissingSection key) +lookupSection key (s@(Section k v):xs) + | key == k = pure (v, xs) + | otherwise = do (v',xs') <- lookupSection 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 a = MkLoad { unLoad :: ReaderT [Text] (Except [LoadError]) a } + deriving (Functor, Applicative, Monad, Alternative, MonadPlus) + +-- | 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 = LoadError [Text] Problem -- ^ path to problem and problem description + deriving (Eq, Ord, Read, Show) + + +-- | Run the Load computation until it produces a result or terminates +-- with a list of errors. +runLoad :: Load a -> Either [LoadError] 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 + | UnusedSections [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 a -> Load a +scope key (MkLoad m) = MkLoad (local (key:) m) + +-- | Abort value specification matching with the given error. +loadFail :: Problem -> Load a +loadFail cause = MkLoad $ + do path <- ask + lift (throwE [LoadError (reverse path) cause]) diff --git a/src/Config/Schema/Spec.hs b/src/Config/Schema/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema/Spec.hs @@ -0,0 +1,295 @@ +{-# Language FlexibleInstances, RankNTypes, GADTs, KindSignatures #-} +{-# Language GeneralizedNewtypeDeriving #-} + +{-| +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 + , atomSpec + , anyAtomSpec + , listSpec + , customSpec + , namedSpec + + -- * Derived specifications + , oneOrList + , numSpec + , yesOrNoSpec + , stringSpec + + -- * Executing specifications + , runSections + , runSections_ + , runValueSpecs + , runValueSpecs_ + + -- * Primitive specifications + , SectionSpec(..) + , ValueSpec(..) + + ) where + +import Control.Applicative.Free (Ap, runAp, runAp_, liftAp) +import Data.Functor.Const (Const(..)) +import Data.Functor.Coyoneda (Coyoneda(..), liftCoyoneda, lowerCoyoneda) +import Data.Functor.Compose (Compose(..), getCompose) +import Data.Functor.Alt (Alt(..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as Text + +------------------------------------------------------------------------ +-- 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. +sectionSpec :: SectionSpec a -> SectionSpecs a +sectionSpec = MkSectionSpecs . liftAp + + +runSections :: Applicative f => (forall x. SectionSpec x -> f x) -> SectionSpecs a -> f a +runSections f (MkSectionSpecs s) = runAp f s + + +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 = sectionSpec (ReqSection n i valuesSpec) + + +-- | Specification for a required section with an explicit value specification. +reqSection' :: + Text {- ^ section name -} -> + Text {- ^ description -} -> + ValueSpecs a {- ^ value specification -} -> + SectionSpecs a +reqSection' n i w = sectionSpec (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 = sectionSpec (OptSection n i valuesSpec) + + +-- | Specification for an optional section with an explicit value specification. +optSection' :: + Text {- ^ section name -} -> + Text {- ^ description -} -> + ValueSpecs a {- ^ value specification -} -> + SectionSpecs (Maybe a) +optSection' n i w = sectionSpec (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 + + -- | 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. +newtype ValueSpecs a = MkValueSpecs { unValueSpecs :: Compose 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. +-- +-- Unlike 'runValueSpecs_', this allows the result of the interpretation to be indexed +-- by the type of the primitive value specifications. +runValueSpecs :: Functor f => (forall x. ValueSpec x -> f x) -> ValueSpecs a -> NonEmpty (f a) +runValueSpecs f = fmap (lowerCoyoneda . hoistCoyoneda f) . getCompose . unValueSpecs + + +-- | Given an interpretation of a primitive value specification, extract a list of +-- the possible interpretations of a disjunction of value specifications. +runValueSpecs_ :: (forall x. ValueSpec x -> m) -> ValueSpecs a -> NonEmpty m +runValueSpecs_ f = fmap getConst . runValueSpecs (Const . f) + + +-- | Lift a primitive value specification to 'ValueSpecs'. +valueSpec :: ValueSpec a -> ValueSpecs a +valueSpec = MkValueSpecs . Compose . 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 = valueSpec TextSpec +instance Spec Integer where valuesSpec = valueSpec IntegerSpec +instance Spec Rational where valuesSpec = valueSpec RationalSpec +instance Spec Int where valuesSpec = fromInteger <$> valuesSpec +instance Spec a => Spec [a] where valuesSpec = valueSpec (ListSpec valuesSpec) +instance (Spec a, Spec b) => Spec (Either a b) where + valuesSpec = Left <$> valuesSpec Right <$> valuesSpec + + +-- | Specification for matching a particular atom. +atomSpec :: Text -> ValueSpecs () +atomSpec = valueSpec . AtomSpec + +-- | Specification for matching any atom. Matched atom is returned. +anyAtomSpec :: ValueSpecs Text +anyAtomSpec = valueSpec 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 a list of values each satisfying a +-- given element specification. +listSpec :: ValueSpecs a -> ValueSpecs [a] +listSpec = valueSpec . 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 = valueSpec (SectionSpecs i s) + + +-- | 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 = valueSpec (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 = valueSpec (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") + +------------------------------------------------------------------------ + +-- | Lift a natural transformation to be a natural transformation of +-- 'Coyoneda'. +hoistCoyoneda :: (forall x. f x -> g x) -> (Coyoneda f a -> Coyoneda g a) +hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)