diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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" diff --git a/config-schema.cabal b/config-schema.cabal --- a/config-schema.cabal +++ b/config-schema.cabal @@ -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 diff --git a/src/Config/Schema/Docs.hs b/src/Config/Schema/Docs.hs --- a/src/Config/Schema/Docs.hs +++ b/src/Config/Schema/Docs.hs @@ -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 diff --git a/src/Config/Schema/Load.hs b/src/Config/Schema/Load.hs --- a/src/Config/Schema/Load.hs +++ b/src/Config/Schema/Load.hs @@ -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 diff --git a/src/Config/Schema/Load/Error.hs b/src/Config/Schema/Load/Error.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema/Load/Error.hs @@ -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) diff --git a/src/Config/Schema/Spec.hs b/src/Config/Schema/Spec.hs --- a/src/Config/Schema/Spec.hs +++ b/src/Config/Schema/Spec.hs @@ -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) diff --git a/src/Config/Schema/Types.hs b/src/Config/Schema/Types.hs new file mode 100644 --- /dev/null +++ b/src/Config/Schema/Types.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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\""]