summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEricMertens <>2017-05-19 16:25:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-19 16:25:00 (GMT)
commit1eff0cf9201084b92d765dfaa87382a1848702cf (patch)
tree51538ab4d46bee66d644bcb6dd063b1882a8dcf2
parent3fcd7fc88e11ab836216170991450cdbaeb0bf09 (diff)
version 0.4.0.00.4.0.0
-rw-r--r--ChangeLog.md8
-rw-r--r--README.md2
-rw-r--r--config-schema.cabal4
-rw-r--r--src/Config/Schema/Docs.hs77
-rw-r--r--src/Config/Schema/Load.hs42
5 files changed, 88 insertions, 45 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 5b64150..5d985bb 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,13 @@
# Revision history for config-schema
+## 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
diff --git a/README.md b/README.md
index f2e10c5..be78d16 100644
--- a/README.md
+++ b/README.md
@@ -82,7 +82,7 @@ printDoc = print (generateDocs exampleSpec)
-- name: REQUIRED text
-- Kid's name
-example :: Either (NonEmpty LoadError) Text
+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"
diff --git a/config-schema.cabal b/config-schema.cabal
index f53ef36..8240e4b 100644
--- a/config-schema.cabal
+++ b/config-schema.cabal
@@ -1,5 +1,5 @@
name: config-schema
-version: 0.3.1.1
+version: 0.4.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.
@@ -33,7 +33,7 @@ library
pretty >=1.1.2 && <1.2,
semigroupoids >=5.1 && <5.3,
text >=1.2 && <1.3,
- transformers >=0.5 && <0.6
+ transformers >=0.4 && <0.6
if flag(use-semigroups)
build-depends: base <4.9, semigroups >=0.18 && <0.19
diff --git a/src/Config/Schema/Docs.hs b/src/Config/Schema/Docs.hs
index 3093260..834d115 100644
--- a/src/Config/Schema/Docs.hs
+++ b/src/Config/Schema/Docs.hs
@@ -1,4 +1,4 @@
-{-# Language OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}
+{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}
{-|
Module : Config.Schema.Docs
@@ -36,13 +36,19 @@ 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)
+import Text.PrettyPrint
+ (Doc, fsep, text, (<>), ($+$), (<+>), nest, empty, hsep, parens)
import Config.Schema.Spec
@@ -53,7 +59,7 @@ generateDocs spec = vcat' docLines
sectionLines :: (Text, Doc) -> [Doc]
sectionLines (name, fields) = [text "", txt name, nest 4 fields]
- (topMap, topDoc) = runDocBuilder (valuesDoc spec)
+ (topDoc, topMap) = runDocBuilder (valuesDoc False spec)
docLines =
case runValueSpecs_ (pure . SomeSpec) spec of
@@ -77,18 +83,18 @@ 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
+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 w
- OptSection name desc w -> aux empty name desc <$> valuesDoc w
+ 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 $+$
+ (txt name <> ":") <+> req <+> val $+$
if Text.null desc
then empty
else nest 4 (fsep (txt <$> Text.splitOn " " desc)) -- line wrap logic
@@ -97,13 +103,20 @@ sectionDoc s =
-- | 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 Doc
-valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ (fmap pure valueDoc)
+--
+-- 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 :: [Doc] -> Doc
-disjunction = hsep . intersperse "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.
@@ -116,25 +129,47 @@ valueDoc w =
AtomSpec a -> pure ("`" <> txt a <> "`")
AnyAtomSpec -> pure "atom"
SectionSpecs l s -> sectionsDoc l s
- NamedSpec l s -> emitDoc l =<< valuesDoc s
- CustomSpec l w' -> (txt l <+>) <$> valuesDoc w'
- ListSpec ws -> ("list of" <+>) <$> valuesDoc ws
- AssocSpec ws -> ("association list of" <+>) <$> valuesDoc ws
+ 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 { runDocBuilder :: (Map Text Doc, a) }
- deriving (Functor, Applicative, Monad, Monoid, Show)
+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 -} ->
- Doc {- ^ section body -} ->
- DocBuilder Doc
-emitDoc l xs = DocBuilder (Map.singleton l xs, txt l)
+ 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@
------------------------------------------------------------------------
diff --git a/src/Config/Schema/Load.hs b/src/Config/Schema/Load.hs
index fe546f2..5cd34c4 100644
--- a/src/Config/Schema/Load.hs
+++ b/src/Config/Schema/Load.hs
@@ -40,13 +40,13 @@ import Config.Schema.Spec
-- the interpretation of that value or the list of errors
-- encountered.
loadValue ::
- ValueSpecs a {- ^ specification -} ->
- Value Position {- ^ value -} ->
- Either (NonEmpty LoadError) a {- ^ errors or decoded value -}
+ ValueSpecs a {- ^ specification -} ->
+ Value p {- ^ value -} ->
+ Either (NonEmpty (LoadError p)) a {- ^ errors or decoded value -}
loadValue spec val = runLoad (getValue spec val)
-getSection :: Position -> SectionSpec a -> StateT [Section Position] Load a
+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))
@@ -55,7 +55,7 @@ getSection pos (OptSection k _ w) =
lift (traverse (scope k . getValue w) mb)
-getSections :: Position -> SectionSpecs a -> [Section Position] -> Load a
+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
@@ -63,12 +63,12 @@ getSections pos spec xs =
Just ss -> asum1 (fmap (\s -> loadFail (sectionAnn s) (UnusedSection (sectionName s))) ss)
-getValue :: ValueSpecs a -> Value Position -> Load a
+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 Position -> ValueSpec a -> Load a
+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
@@ -94,14 +94,14 @@ getValue1 v AssocSpec{} = loadFail (valueAnn v) (SpecMismatch "associatio
-- | 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 Position] -> Load [a]
+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 Position] -> Load [(Text,a)]
+getAssoc :: ValueSpecs a -> [Section p] -> Load p [(Text,a)]
getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> getValue w v
@@ -110,8 +110,8 @@ getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> getValue w v
getCustom ::
Text {- ^ label -} ->
ValueSpecs (Maybe a) {- ^ specification -} ->
- Value Position {- ^ value -} ->
- Load a
+ Value p {- ^ value -} ->
+ Load p a
getCustom l w v =
do x <- getValue w v
case x of
@@ -121,10 +121,10 @@ getCustom l w v =
-- | Extract a section from a list of sections by name.
lookupSection ::
- Position {- ^ starting position of sections -} ->
- Text {- ^ section name -} ->
- [Section p] {- ^ available sections -} ->
- Load (Value p, [Section p]) {- ^ found value and remaining sections -}
+ 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)
@@ -153,21 +153,21 @@ floatingToInteger x y
-- | 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 (NonEmpty LoadError)) a }
+newtype Load p a = MkLoad { unLoad :: ReaderT [Text] (Except (NonEmpty (LoadError p))) a }
deriving (Functor, Applicative, Monad)
-instance Alt Load where MkLoad x <!> MkLoad y = MkLoad (x <!> y)
+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 = LoadError Position [Text] Problem -- ^ position, path, problem
+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 a -> Either (NonEmpty LoadError) a
+runLoad :: Load p a -> Either (NonEmpty (LoadError p)) a
runLoad = runExcept . flip runReaderT [] . unLoad
@@ -179,11 +179,11 @@ data Problem
deriving (Eq, Ord, Read, Show)
-- | Push a new key onto the stack of nested fields.
-scope :: Text -> Load a -> Load a
+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 :: Position -> Problem -> Load a
+loadFail :: p -> Problem -> Load p a
loadFail pos cause = MkLoad $
do path <- ask
lift (throwE (pure (LoadError pos (reverse path) cause)))