config-schema 0.5.0.1 → 1.0.0.0

raw patch · 9 files changed

+765/−450 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• README.md +3/−3
• config-schema.cabal +23/−15
• src/Config/Schema/Docs.hs +12/−11
• src/Config/Schema/Load.hs +78/−157
• src/Config/Schema/Load/Error.hs +208/−0
• src/Config/Schema/Spec.hs +230/−252
• src/Config/Schema/Types.hs +185/−0
• tests/Main.hs +12/−12

@@ -1,5 +1,19 @@ # Revision history for config-schema +## 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 

@@ -44,7 +44,7 @@ exampleValue :: Value Position Right exampleValue = parse exampleFile -exampleSpec :: ValueSpecs Text+exampleSpec :: ValueSpec Text exampleSpec = sectionsSpec "" $   do name  <- reqSection  "name" "Full name"      age   <- reqSection  "age"  "Age of user"@@ -63,12 +63,12 @@              Text.intercalate ", " kids <>              happyText -kidSpec :: ValueSpecs Text+kidSpec :: ValueSpec Text kidSpec = sectionsSpec "kid" (reqSection "name" "Kid's name")   -- | Matches the 'yes' and 'no' atoms-yesOrNo :: ValueSpecs Bool+yesOrNo :: ValueSpec Bool yesOrNo = True  <$ atomSpec "yes" <!>           False <$ atomSpec "no" 

@@ -1,5 +1,6 @@+cabal-version:       2.2 name:                config-schema-version:             0.5.0.1+version:             1.0.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.@@ -14,31 +15,38 @@ 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+tested-with:         GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5  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.12,-                        config-value   >=0.6   && <0.7,-                        containers     >=0.5   && <0.6,-                        free           >=4.12  && <5.1,-                        kan-extensions >=5.0.2 && <5.2,-                        pretty         >=1.1.2 && <1.2,-                        semigroupoids  >=5.1   && <5.3,-                        text           >=1.2   && <1.3,-                        transformers   >=0.4   && <0.6+  exposed-modules:+    Config.Schema+    Config.Schema.Docs+    Config.Schema.Load+    Config.Schema.Load.Error+    Config.Schema.Spec+    Config.Schema.Types +  build-depends:+    base           >=4.8   && <4.13,+    config-value   >=0.6   && <0.7,+    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   && <1.3,+    transformers   >=0.4   && <0.6,+   if flag(use-semigroups)-        build-depends: base <4.9, semigroups >=0.18 && <0.19+    build-depends: base <4.9, semigroups >=0.18 && <0.19   else-        build-depends: base >= 4.9+    build-depends: base >= 4.9    hs-source-dirs:       src   default-language:     Haskell2010

@@ -16,7 +16,7 @@ to be able to generate another form are exported by "Config.Schema.Spec".  @-configSpec :: ValueSpecs (Text,Maybe Int)+configSpec :: ValueSpec (Text,Maybe Int) configSpec = sectionsSpec ""            $ liftA2 (,)                (reqSection "username" "Name used to login")@@ -52,9 +52,10 @@ import           Prelude hiding ((<>))  import           Config.Schema.Spec+import           Config.Schema.Types  -- | Default documentation generator.-generateDocs :: ValueSpecs a -> Doc+generateDocs :: ValueSpec a -> Doc generateDocs spec = vcat' docLines   where     sectionLines :: (Text, Doc) -> [Doc]@@ -63,9 +64,9 @@     (topDoc, topMap) = runDocBuilder (valuesDoc False spec)      docLines =-      case runValueSpecs_ (pure . SomeSpec) spec of+      case runValueSpec_ (pure . SomeSpec) spec of         -- single, top-level sections spec-        SomeSpec (SectionSpecs name _) :| []+        SomeSpec (SectionsSpec name _) :| []           | Just top <- Map.lookup name topMap ->               txt "Top-level configuration file fields:" :               nest 4 top :@@ -78,17 +79,17 @@   -- | Forget the type of the value spec-data SomeSpec where SomeSpec :: ValueSpec a -> SomeSpec+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 -> SectionSpecs a -> DocBuilder Doc+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 :: SectionSpec a -> DocBuilder Doc+sectionDoc :: PrimSectionSpec a -> DocBuilder Doc sectionDoc s =   case s of     ReqSection name desc w -> aux "REQUIRED" name desc <$> valuesDoc False w@@ -107,9 +108,9 @@ -- -- 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 :: Bool {- ^ nested -} -> ValueSpec a -> DocBuilder Doc valuesDoc nested =-  fmap (disjunction nested) . sequenceA . runValueSpecs_ (fmap pure valueDoc)+  fmap (disjunction nested) . sequenceA . runValueSpec_ (fmap pure valueDoc)   -- | Combine a list of text with the word @or@.@@ -121,7 +122,7 @@   -- | Compute the documentation fragment for an individual value specification.-valueDoc :: ValueSpec a -> DocBuilder Doc+valueDoc :: PrimValueSpec a -> DocBuilder Doc valueDoc w =   case w of     TextSpec         -> pure "text"@@ -129,7 +130,7 @@     RationalSpec     -> pure "number"     AtomSpec a       -> pure ("`" <> txt a <> "`")     AnyAtomSpec      -> pure "atom"-    SectionSpecs l s -> sectionsDoc l s+    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

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, GADTs #-}+{-# Language GADTs #-} {-| Module      : Config.Schema.Load Description : Operations to extract a value from a configuration.@@ -15,166 +15,137 @@   , loadValueFromFile    -- * Errors-  , SchemaError(..)-  , LoadError(..)+  , ValueSpecMismatch(..)+  , PrimMismatch(..)   , Problem(..)   ) where -import           Control.Exception                (Exception(..), throwIO)+import           Control.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           Control.Monad.Trans.State        (StateT(..), runStateT, state)+import           Control.Monad.Trans.Except       (Except, runExcept, throwE, withExcept) 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+import           Config.Schema.Types+import           Config.Schema.Load.Error  --- | Match a 'Value' against a 'ValueSpecs' and return either+-- | Match a 'Value' against a 'ValueSpec' and return either -- the interpretation of that value or the list of errors -- encountered. loadValue ::-  ValueSpecs a                      {- ^ specification           -} ->+  ValueSpec a                       {- ^ specification           -} ->   Value p                           {- ^ value                   -} ->-  Either (NonEmpty (LoadError p)) a {- ^ errors or decoded value -}-loadValue spec val = runLoad (getValue spec val)+  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 'SchemaError'+-- Throws 'IOError', 'ParseError', or 'ValueSpecMismatch' loadValueFromFile ::-  ValueSpecs a {- ^ specification -} ->-  FilePath     {- ^ filename      -} ->+  ValueSpec 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)-+     let exceptIO m = either throwIO return m+     val <- exceptIO (parse txt)+     exceptIO (loadValue spec val) -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)+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 :: p -> SectionSpecs a -> [Section p] -> Load p a-getSections pos spec xs =-  do (a,leftovers) <- runStateT (runSections (getSection pos) spec) xs+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 -> asum1 (fmap (\s -> loadFail (sectionAnn s) (UnusedSection (sectionName s))) ss)+       Just ss -> throwE (UnusedSections (fmap sectionName ss))  -getValue :: ValueSpecs a -> Value p -> Load p a-getValue s v = runValueSpecs (getValue1 v) s+getValue :: ValueSpec a -> Value p -> Except (ValueSpecMismatch p) a+getValue s v = withExcept (ValueSpecMismatch 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 v) (runValueSpec (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 :: Value p -> PrimValueSpec a -> Except (NonEmpty (PrimMismatch p)) a+getValue1 v prim = withExcept (pure . PrimMismatch (describeSpec prim))+                              (getValue2 v prim) -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")+-- | 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)   IntegerSpec        = pure n+getValue2 (Floating _ a b) IntegerSpec | Just i <- floatingToInteger a b = pure i+getValue2 (Number _ _ n)   RationalSpec       = pure (fromInteger n)+getValue2 (Floating _ a b) RationalSpec       = pure (floatingToRational a b)+getValue2 (List _ xs)      (ListSpec w)       = getList w xs+getValue2 (Atom _ b)       AnyAtomSpec        = pure (atomName b)+getValue2 (Atom _ b)       (AtomSpec a)+  | a == atomName b = pure ()+  | otherwise       = throwE WrongAtom+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 :: ValueSpecs a -> [Value p] -> Load p [a]-getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [1::Int ..]+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 :: ValueSpecs a -> [Section p] -> Load p [(Text,a)]-getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> scope k (getValue w v)-+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 ::-  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+  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 ::-  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')+  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')  ------------------------------------------------------------------------ @@ -189,53 +160,3 @@   | 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

@@ -0,0 +1,208 @@+{-# Language GADTs, OverloadedStrings #-}+{-|+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+  ) 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           Data.Monoid ((<>))++import           Config+import           Config.Schema.Types++-- | Newtype wrapper for schema load errors.+data ValueSpecMismatch p =+  -- | Problem value and list of specification failures+  ValueSpecMismatch (Value p) (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.+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'.+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+  | WrongAtom                                    -- ^ atoms didn't match+  deriving Show++-- | Describe outermost shape of a 'PrimValueSpec'+describeSpec :: PrimValueSpec a -> Text+describeSpec TextSpec                   = "text"+describeSpec IntegerSpec                = "integer"+describeSpec RationalSpec               = "number"+describeSpec AnyAtomSpec                = "atom"+describeSpec (AtomSpec a)               = "atom `" <> a <> "`"+describeSpec (ListSpec _)               = "list"+describeSpec (SectionsSpec name _)      = name+describeSpec (AssocSpec _)              = "sections"+describeSpec (CustomSpec name _)        = name+describeSpec (NamedSpec name _)         = name++-- | Describe outermost shape of a 'Value'+describeValue :: Value p -> String+describeValue Text{}     = "text"+describeValue Number{}   = "integer"+describeValue Floating{} = "number"+describeValue (Atom _ a) = "atom `" <> Text.unpack (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 v prims) = f (ValueSpecMismatch 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 v xs)+  | Just xs' <- NonEmpty.nonEmpty (NonEmpty.filter isNotTypeMismatch xs)+  = ValueSpecMismatch v xs'+  where+    isNotTypeMismatch (PrimMismatch _ TypeMismatch) = False+    isNotTypeMismatch _                             = True+removeTypeMismatch1 v = v++-- | 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.+prettyValueSpecMismatch :: ErrorAnnotation p => ValueSpecMismatch p -> Doc+prettyValueSpecMismatch (ValueSpecMismatch v es) =+  heading $+$ errors+  where+    heading = displayAnnotation (valueAnn v) <> text (describeValue 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.+prettyPrimMismatch :: ErrorAnnotation p => PrimMismatch p -> Doc+prettyPrimMismatch (PrimMismatch spec problem) =+  case prettyProblem problem of+    (summary, detail) ->+      (text "*" <+> text (Text.unpack spec) <+> summary) $+$ nest 4 detail++-- | Pretty-printer for 'Problem' that generates a summary line+-- as well as a detailed description (depending on the error)+prettyProblem ::+  ErrorAnnotation p =>+  Problem p ->+  (Doc, Doc) {- ^ summary, detailed -}+prettyProblem p =+  case p of+    TypeMismatch ->+      ( text "- type mismatch"+      , empty)+    WrongAtom ->+      ( text "- wrong atom"+      , 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'+class (Typeable a, Show a) => ErrorAnnotation a where+  displayAnnotation :: a -> Doc++-- | Renders a 'Position' as @line:column:@+instance ErrorAnnotation Position where+  displayAnnotation pos = hcat [int (posLine pos), colon, int (posColumn pos), colon]++-- | Renders as an empty document+instance ErrorAnnotation () where+  displayAnnotation _ = empty++-- | 'displayException' implemented with 'prettyValueSpecMismatch'+instance ErrorAnnotation p => Exception (ValueSpecMismatch p) where+  displayException = show . prettyValueSpecMismatch . rewriteMismatch (focusMismatch1 . removeTypeMismatch1)

@@ -1,17 +1,16 @@-{-# Language FlexibleInstances, RankNTypes, GADTs, KindSignatures #-}-{-# Language DeriveFunctor, GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# Language FlexibleInstances, OverloadedStrings #-}  {-| Module      : Config.Schema.Spec-Description : Types and operations for describing a configuration file format.+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 schemas can be built up using 'Applicative' operations.+file schemas. -These specifications are suitable for be consumed by "Config.Schema.Load"+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@@ -21,16 +20,9 @@ -} module Config.Schema.Spec   (-  -- * Specifying sections-    SectionSpecs-  , reqSection-  , optSection-  , reqSection'-  , optSection'-   -- * Specifying values-  , ValueSpecs-  , Spec(..)+  -- $values+    ValueSpec   , sectionsSpec   , assocSpec   , atomSpec@@ -38,7 +30,16 @@   , listSpec   , customSpec   , namedSpec+  , HasSpec(..) +  -- * Specifying sections+  -- $sections+  , SectionsSpec+  , reqSection+  , optSection+  , reqSection'+  , optSection'+   -- * Derived specifications   , oneOrList   , yesOrNoSpec@@ -48,269 +49,151 @@   , 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 +import           Config.Schema.Types+ --------------------------------------------------------------------------- Specifications for sections+-- 'ValueSpec' builders ------------------------------------------------------------------------ --- | Specifications for single configuration sections.+-- $values ----- 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.+-- '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. ----- @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'.+-- Below we have an example configuration record that can be matched+-- from a configuration file. ----- 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.+-- More documentation for defining key-value pairs is available below. ----- 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'.+-- 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. ----- 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.+-- @+-- {-\# Language RecordWildCards, OverloadedStrings, ApplicativeDo \#-}+-- module Example where ----- 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.+-- import "Config.Schema"+-- import "Data.Functor.Alt" (('<!>'))+-- import "Data.Maybe"       ('Data.Maybe.fromMaybe')+-- import "Data.Text"        ('Text') ----- 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'.+-- data Config = Config+--   { userName :: UserName+--   , retries  :: 'Int'+--   } ----- @since 0.2.0.0-liftValueSpec :: ValueSpec a -> ValueSpecs a-liftValueSpec = MkValueSpecs . pure . liftCoyoneda------------------------------------------------------------------------------ 'ValueSpecs' builders--------------------------------------------------------------------------+-- 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 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+class    HasSpec a        where anySpec :: ValueSpec a+instance HasSpec Text     where anySpec = primValueSpec TextSpec+instance HasSpec Integer  where anySpec = primValueSpec IntegerSpec+instance HasSpec Rational where anySpec = primValueSpec RationalSpec+instance HasSpec Int      where anySpec = sizedBitsSpec "machine-bit signed"+instance HasSpec Int8     where anySpec = sizedBitsSpec "8-bit signed"+instance HasSpec Int16    where anySpec = sizedBitsSpec "16-bit signed"+instance HasSpec Int32    where anySpec = sizedBitsSpec "32-bit signed"+instance HasSpec Int64    where anySpec = sizedBitsSpec "64-bit signed"+instance HasSpec Word     where anySpec = sizedBitsSpec "machine-bit unsigned"+instance HasSpec Word8    where anySpec = sizedBitsSpec "8-bit unsigned"+instance HasSpec Word16   where anySpec = sizedBitsSpec "16-bit unsigned"+instance HasSpec Word32   where anySpec = sizedBitsSpec "32-bit unsigned"+instance HasSpec Word64   where anySpec = sizedBitsSpec "64-bit unsigned" -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"+instance HasSpec a => HasSpec [a] where+  anySpec = primValueSpec (ListSpec anySpec) -sizedBitsSpec :: (Integral a, Bits a) => Text -> ValueSpecs a-sizedBitsSpec name = customSpec name (liftValueSpec IntegerSpec) toIntegralSized+instance (HasSpec a, HasSpec b) => HasSpec (Either a b) where+  anySpec = Left <$> anySpec <!> Right <$> anySpec +sizedBitsSpec :: (Integral a, Bits a) => Text -> ValueSpec a+sizedBitsSpec name = customSpec name (primValueSpec IntegerSpec) check+  where+    check i = case toIntegralSized i of+                Nothing -> Left "out of bounds"+                Just j  -> Right j+ -- | Specification for matching a particular atom.-atomSpec :: Text -> ValueSpecs ()-atomSpec = liftValueSpec . AtomSpec+atomSpec :: Text -> ValueSpec ()+atomSpec = primValueSpec . AtomSpec  -- | Specification for matching any atom. Matched atom is returned.-anyAtomSpec :: ValueSpecs Text-anyAtomSpec = liftValueSpec AnyAtomSpec+anyAtomSpec :: ValueSpec Text+anyAtomSpec = primValueSpec AnyAtomSpec  -- | Specification for matching any text as a 'String'-stringSpec :: ValueSpecs String-stringSpec = Text.unpack <$> valuesSpec+stringSpec :: ValueSpec String+stringSpec = Text.unpack <$> anySpec  -- | Specification for matching any integral number.-numSpec :: Num a => ValueSpecs a-numSpec = fromInteger <$> valuesSpec+numSpec :: Num a => ValueSpec a+numSpec = fromInteger <$> anySpec  -- | Specification for matching any fractional number. -- -- @since 0.2.0.0-fractionalSpec :: Fractional a => ValueSpecs a-fractionalSpec = fromRational <$> valuesSpec+fractionalSpec :: Fractional a => ValueSpec a+fractionalSpec = fromRational <$> anySpec  -- | Specification for matching a list of values each satisfying a -- given element specification.-listSpec :: ValueSpecs a -> ValueSpecs [a]-listSpec = liftValueSpec . ListSpec+listSpec :: ValueSpec a -> ValueSpec [a]+listSpec = primValueSpec . ListSpec   -- | Named subsection value specification. The unique identifier will be used@@ -318,9 +201,9 @@ -- 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)+  SectionsSpec a {- ^ underlying specification        -} ->+  ValueSpec a+sectionsSpec i s = primValueSpec (SectionsSpec i s)   -- | Specification for a section list where the keys are user-defined.@@ -329,9 +212,9 @@ -- -- @since 0.3.0.0 assocSpec ::-  ValueSpecs a {- ^ underlying specification -} ->-  ValueSpecs [(Text,a)]-assocSpec = liftValueSpec . AssocSpec+  ValueSpec a {- ^ underlying specification -} ->+  ValueSpec [(Text,a)]+assocSpec = primValueSpec . AssocSpec   -- | Named value specification. This is useful for factoring complicated@@ -339,28 +222,28 @@ -- complex specifications. namedSpec ::   Text         {- ^ name                     -} ->-  ValueSpecs a {- ^ underlying specification -} ->-  ValueSpecs a-namedSpec n s = liftValueSpec (NamedSpec n s)+  ValueSpec a {- ^ underlying specification -} ->+  ValueSpec a+namedSpec n s = primValueSpec (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 :: ValueSpec a -> ValueSpec [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))+customSpec :: Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b+customSpec lbl w f = primValueSpec (CustomSpec lbl (f <$> w))   -- | Specification for using @yes@ and @no@ to represent booleans 'True' -- and 'False' respectively-yesOrNoSpec :: ValueSpecs Bool+yesOrNoSpec :: ValueSpec Bool yesOrNoSpec = True  <$ atomSpec (Text.pack "yes")           <!> False <$ atomSpec (Text.pack "no") @@ -368,11 +251,106 @@ -- | Matches a non-empty list. -- -- @since 0.2.0.0-nonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a)-nonemptySpec s = customSpec "nonempty" (listSpec s) NonEmpty.nonEmpty+nonemptySpec :: ValueSpec a -> 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 :: ValueSpecs a -> ValueSpecs (NonEmpty a)+oneOrNonemptySpec :: ValueSpec a -> ValueSpec (NonEmpty a) oneOrNonemptySpec s = pure <$> s <!> nonemptySpec s+++------------------------------------------------------------------------+-- 'SectionsSpec' builders+------------------------------------------------------------------------++-- $sections+-- 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)

@@ -0,0 +1,185 @@+{-# 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           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 integral numbers+  IntegerSpec :: PrimValueSpec Integer++  -- | Matches any number+  RationalSpec :: PrimValueSpec Rational++  -- | Matches any atom+  AnyAtomSpec :: PrimValueSpec Text++  -- | Specific atom to be matched+  AtomSpec :: Text -> PrimValueSpec ()++  -- | 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++-- | 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.+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.+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

@@ -23,9 +23,9 @@ test ::   Show a =>   Eq   a =>-  ValueSpecs a {- ^ specification to match -} ->-  a            {- ^ expected output        -} ->-  [[Text]]     {- ^ inputs sources         -} ->+  ValueSpec a {- ^ specification to match -} ->+  a           {- ^ expected output        -} ->+  [[Text]]    {- ^ inputs sources         -} ->   IO () test spec expected txtss =   for_ txtss $ \txts ->@@ -41,18 +41,18 @@ main :: IO () main = sequenceA_ -  [ test valuesSpec ("Hello world"::Text)+  [ test anySpec ("Hello world"::Text)     [["\"Hello world\""]     ,["\"H\\101l\\&l\\o157 \\"      ,"  \\w\\x6frld\""]     ] -  , test valuesSpec (1234::Integer)+  , test anySpec (1234::Integer)     [["1234"]     ,["1234.0"]     ] -  , test valuesSpec (0.65::Rational)+  , test anySpec (0.65::Rational)     [["0.65e0"]     ,["65e-2"]     ,["6.5e-1"]@@ -65,7 +65,7 @@   , test (atomSpec "testing-1-2-3") ()     [["testing-1-2-3"]] -  , test (listSpec valuesSpec) ([]::[Integer])+  , test (listSpec anySpec) ([]::[Integer])     [["[]"]     ,["[ ]"]] @@ -75,7 +75,7 @@     ,["* ḿyatoḿ"]     ] -  , test valuesSpec [1,2,3::Int]+  , test anySpec [1,2,3::Int]     [["[1,2,3]"]     ,["[1,2,3,]"]     ,["* 1"@@ -83,7 +83,7 @@      ,"* 3"]     ] -  , test (listSpec valuesSpec) [[1,2],[3,4::Int]]+  , test (listSpec anySpec) [[1,2],[3,4::Int]]     [["[[1,2,],[3,4]]"]     ,["*[1,2]"      ,"*[3,4]"]@@ -94,19 +94,19 @@      ]     ] -  , test (assocSpec valuesSpec) ([]::[(Text,Int)])+  , test (assocSpec anySpec) ([]::[(Text,Int)])     [["{}"]     ,["{ }"]     ] -  , test (assocSpec valuesSpec) [("k1",10::Int), ("k2",20)]+  , test (assocSpec anySpec) [("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) ]+  , test anySpec [ Left (1::Int), Right ("two"::Text) ]     [["[1, \"two\"]"]     ,["* 1"      ,"* \"two\""]