config-schema 0.3.1.1 → 0.4.0.0

raw patch · 5 files changed

+88/−45 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +1/−1
• config-schema.cabal +2/−2
• src/Config/Schema/Docs.hs +56/−21
• src/Config/Schema/Load.hs +21/−21

@@ -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

@@ -82,7 +82,7 @@ --     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"

@@ -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 @@                         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

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}+{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}  {-| Module      : Config.Schema.Docs@@ -36,13 +36,19 @@   ( 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 @@     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 @@ -- | 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,15 +103,22 @@ -- | 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. valueDoc :: ValueSpec a -> DocBuilder Doc valueDoc w =@@ -116,25 +129,47 @@     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@  ------------------------------------------------------------------------ 

@@ -40,13 +40,13 @@ -- 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 @@      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 @@        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 @@  -- | 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 @@ 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 @@  -- | 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 @@ -- | 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 @@   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)))