diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for config-schema +## 0.3.0.0 -- 2017-05-09 + +* Added "association list" specifications +* Use `pretty` library for documentation generation +* Reorder parameters so that documentation comes last +* Hide implementations of `ValueSpecs` and `SectionSpecs` + ## 0.2.0.0 -- 2017-05-07 * Expose `liftValueSpec` and `liftSectionSpec` diff --git a/config-schema.cabal b/config-schema.cabal --- a/config-schema.cabal +++ b/config-schema.cabal @@ -1,5 +1,5 @@ name: config-schema -version: 0.2.0.0 +version: 0.3.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. @@ -17,6 +17,7 @@ cabal-version: >=1.10 homepage: https://github.com/glguy/config-schema bug-reports: https://github.com/glguy/config-schema/issues +tested-with: GHC==8.0.2 source-repository head type: git @@ -24,14 +25,23 @@ library exposed-modules: Config.Schema, Config.Schema.Docs, Config.Schema.Load, Config.Schema.Spec - build-depends: base >=4.9 && <4.11, - text >=1.2 && <1.3, - free >=4.12 && <4.13, - kan-extensions >=5.0 && <5.1, - semigroupoids >=5.2 && <5.3, - transformers >=0.5 && <0.6, - config-value >=0.5 && <0.6, - containers >=0.5 && <0.6 + build-depends: base >=4.9 && <4.11, + config-value >=0.6 && <0.7, + containers >=0.5 && <0.6, + free >=4.12 && <4.13, + kan-extensions >=5.0.2 && <5.1, + pretty >=1.1.3 && <1.2, + semigroupoids >=5.2 && <5.3, + text >=1.2 && <1.3, + transformers >=0.5 && <0.6 hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests + build-depends: base, config-value, config-schema, text default-language: Haskell2010 ghc-options: -Wall 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 @@ -36,93 +36,100 @@ ( generateDocs ) where +import Data.List (intersperse) import Data.Map (Map) import qualified Data.Map as Map -import Data.Monoid -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text +import Text.PrettyPrint (Doc, text, ($+$), (<>), (<+>), nest, empty, hsep) import Config.Schema.Spec -- | Default documentation generator. This generator is specifically -- for configuration specifications where the top-level specification -- is named with the empty string (@""@). -generateDocs :: ValueSpecs a -> Text -generateDocs spec = Text.unlines - ("Configuration file fields:" - : map (" " <>) top - ++ concatMap sectionLines (Map.toList m')) - +generateDocs :: ValueSpecs a -> Doc +generateDocs spec + = vcat' + $ txt "Configuration file fields:" + : nest 4 top + : concatMap sectionLines (Map.toList m') where topname = "" Just top = Map.lookup topname m - DocBuilder (m,"") = valuesDoc spec + (m,"") = runDocBuilder (valuesDoc spec) m' = Map.delete topname m - sectionLines :: (Text, [Text]) -> [Text] - sectionLines (name, fields) - = "" - : name - : map (" "<>) fields + sectionLines :: (Text, Doc) -> [Doc] + sectionLines (name, fields) = [text "", txt name, nest 4 fields] -- | Compute the documentation for a list of sections, store the -- documentation in the sections map and return the name of the section. -sectionsDoc :: Text -> SectionSpecs a -> DocBuilder Text -sectionsDoc l spec = emitDoc l =<< runSections_ sectionDoc spec +sectionsDoc :: Text -> SectionSpecs 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 [Text] +sectionDoc :: SectionSpec a -> DocBuilder Doc sectionDoc s = case s of - ReqSection name desc w -> aux "REQUIRED " name desc <$> valuesDoc w - OptSection name desc w -> aux "" name desc <$> valuesDoc w + ReqSection name desc w -> aux "REQUIRED" name desc <$> valuesDoc w + OptSection name desc w -> aux empty name desc <$> valuesDoc w where aux req name desc val = - (name <> ": " <> req <> val) - : if Text.null desc then [] else [" " <> desc] + txt name <> ":" <+> req <+> val $+$ + if Text.null desc then empty else nest 4 (txt desc) -- | Compute the documentation line for a particular value specification. -- Any sections contained in the specification will be stored in the -- sections map. -valuesDoc :: ValueSpecs a -> DocBuilder Text -valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ valueDoc +valuesDoc :: ValueSpecs a -> DocBuilder Doc +valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ (fmap pure valueDoc) -- | Combine a list of text with the word @or@. -disjunction :: NonEmpty Text -> Text -disjunction = Text.intercalate " or " . NonEmpty.toList +disjunction :: [Doc] -> Doc +disjunction = hsep . intersperse "or" -- | Compute the documentation fragment for an individual value specification. -valueDoc :: ValueSpec a -> DocBuilder Text +valueDoc :: ValueSpec a -> DocBuilder Doc valueDoc w = case w of - TextSpec -> return "text" - IntegerSpec -> return "integer" - RationalSpec -> return "number" - AtomSpec a -> return ("`" <> a <> "`") - AnyAtomSpec -> return "atom" + TextSpec -> pure "text" + IntegerSpec -> pure "integer" + RationalSpec -> pure "number" + AtomSpec a -> pure ("`" <> txt a <> "`") + AnyAtomSpec -> pure "atom" SectionSpecs l s -> sectionsDoc l s - NamedSpec l s -> emitDoc l . pure =<< valuesDoc s - CustomSpec l w' -> ((l <> " ") <>) <$> valuesDoc w' - ListSpec ws -> ("list of " <>) <$> valuesDoc ws + NamedSpec l s -> emitDoc l =<< valuesDoc s + CustomSpec l w' -> (txt l <+>) <$> valuesDoc w' + ListSpec ws -> ("list of" <+>) <$> valuesDoc ws + AssocSpec ws -> ("association list of" <+>) <$> valuesDoc ws -- | A writer-like type. A mapping of section names and documentation -- lines is accumulated. -newtype DocBuilder a = DocBuilder (Map Text [Text], a) +newtype DocBuilder a = DocBuilder { runDocBuilder :: (Map Text Doc, a) } deriving (Functor, Applicative, Monad, Monoid, Show) -- | Given a section name and section body, store the body -- in the map of sections and return the section name. emitDoc :: - Text {- ^ section name -} -> - [Text] {- ^ section body -} -> - DocBuilder Text -emitDoc l xs = DocBuilder (Map.singleton l xs, l) + Text {- ^ section name -} -> + Doc {- ^ section body -} -> + DocBuilder Doc +emitDoc l xs = DocBuilder (Map.singleton l xs, txt l) + +------------------------------------------------------------------------ + +-- | Like text, but works on Text values. +txt :: Text -> Doc +txt = text . Text.unpack + +-- | Like vcat but using ($+$) instead of ($$) to avoid overlap. +vcat' :: [Doc] -> Doc +vcat' = foldr ($+$) empty 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 @@ -18,16 +18,17 @@ , Problem(..) ) where -import Control.Monad (unless, zipWithM) +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 Data.Ratio (numerator, denominator) -import Data.Semigroup.Foldable (asum1) import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text @@ -40,83 +41,94 @@ -- encountered. loadValue :: ValueSpecs a {- ^ specification -} -> - Value {- ^ value -} -> + Value Position {- ^ value -} -> Either (NonEmpty LoadError) a {- ^ errors or decoded value -} loadValue spec val = runLoad (getValue spec val) -getSection :: SectionSpec a -> StateT [Section] Load a -getSection (ReqSection k _ w) = - do v <- StateT (lookupSection k) +getSection :: Position -> SectionSpec a -> StateT [Section Position] Load a +getSection pos (ReqSection k _ w) = + do v <- StateT (lookupSection pos k) lift (scope k (getValue w v)) -getSection (OptSection k _ w) = - do mb <- optional1 (StateT (lookupSection k)) +getSection pos (OptSection k _ w) = + do mb <- optional1 (StateT (lookupSection pos k)) lift (traverse (scope k . getValue w) mb) -getSections :: SectionSpecs a -> [Section] -> Load a -getSections p xs = - do (a,leftover) <- runStateT (runSections getSection p) xs - unless (null leftover) (loadFail (UnusedSections (map sectionName leftover))) - return a +getSections :: Position -> SectionSpecs a -> [Section Position] -> Load a +getSections pos spec xs = + do (a,leftovers) <- runStateT (runSections (getSection pos) spec) xs + case NonEmpty.nonEmpty leftovers of + Nothing -> return a + Just ss -> asum1 (fmap (\s -> loadFail (sectionAnn s) (UnusedSection (sectionName s))) ss) -getValue :: ValueSpecs a -> Value -> Load a -getValue s v = asum1 (runValueSpecs (getValue1 v) s) +getValue :: ValueSpecs a -> Value Position -> Load a +getValue s v = runValueSpecs (getValue1 v) s -- | Match a primitive value specification against a single value. -getValue1 :: Value -> ValueSpec a -> Load a -getValue1 (Text t) TextSpec = pure t -getValue1 (Number _ n) IntegerSpec = pure n -getValue1 (Floating a b) IntegerSpec | Just i <- floatingToInteger a b = pure i -getValue1 (Number _ n) RationalSpec = pure (fromInteger n) -getValue1 (Floating a b) RationalSpec = pure (floatingToRational a b) -getValue1 (List xs) (ListSpec w) = getList w xs -getValue1 (Atom b) AnyAtomSpec = pure (atomName b) -getValue1 (Atom b) (AtomSpec a) | a == atomName b = pure () -getValue1 (Sections s) (SectionSpecs _ w) = getSections w s -getValue1 v (NamedSpec _ w) = getValue w v -getValue1 v (CustomSpec l w) = getCustom l w v +getValue1 :: Value Position -> ValueSpec a -> Load a +getValue1 (Text _ t) TextSpec = pure t +getValue1 (Number _ _ n) IntegerSpec = pure n +getValue1 (Floating _ a b) IntegerSpec | Just i <- floatingToInteger a b = pure i +getValue1 (Number _ _ n) RationalSpec = pure (fromInteger n) +getValue1 (Floating _ a b) RationalSpec = pure (floatingToRational a b) +getValue1 (List _ xs) (ListSpec w) = getList w xs +getValue1 (Atom _ b) AnyAtomSpec = pure (atomName b) +getValue1 (Atom _ b) (AtomSpec a) | a == atomName b = pure () +getValue1 (Sections 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 _ TextSpec = loadFail (SpecMismatch "text") -getValue1 _ IntegerSpec = loadFail (SpecMismatch "integer") -getValue1 _ RationalSpec = loadFail (SpecMismatch "number") -getValue1 _ ListSpec{} = loadFail (SpecMismatch "list") -getValue1 _ AnyAtomSpec = loadFail (SpecMismatch "atom") -getValue1 _ (AtomSpec a) = loadFail (SpecMismatch ("`" <> a <> "`")) -getValue1 _ (SectionSpecs l _) = loadFail (SpecMismatch l) +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") -- | This operation processes all of the values in a list with the given -- value specification and updates the scope with a one-based list index. -getList :: ValueSpecs a -> [Value] -> Load [a] +getList :: ValueSpecs a -> [Value Position] -> Load [a] getList w = zipWithM (\i x -> scope (Text.pack (show i)) (getValue w x)) [1::Int ..] +-- | This operation processes all of the values in a section list +-- against the given specification and associates them with the +-- section name. +getAssoc :: ValueSpecs a -> [Section Position] -> Load [(Text,a)] +getAssoc w = traverse $ \(Section _ k v) -> (,) k <$> getValue 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 {- ^ value -} -> + Value Position {- ^ value -} -> Load a getCustom l w v = do x <- getValue w v case x of - Nothing -> loadFail (SpecMismatch l) + Nothing -> loadFail (valueAnn v) (SpecMismatch l) Just y -> pure y -- | Extract a section from a list of sections by name. lookupSection :: - Text {- ^ section name -} -> - [Section] {- ^ available sections -} -> - Load (Value, [Section]) {- ^ found value and remaining sections -} -lookupSection key [] = loadFail (MissingSection key) -lookupSection key (s@(Section k v):xs) + Position {- ^ starting position of sections -} -> + Text {- ^ section name -} -> + [Section p] {- ^ available sections -} -> + Load (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 key xs + | otherwise = do (v',xs') <- lookupSection pos key xs return (v',s:xs') ------------------------------------------------------------------------ @@ -149,8 +161,8 @@ -- | Type for errors that can be encountered while decoding a value according -- to a specification. The error includes a key path indicating where in -- the configuration file the error occurred. -data LoadError = LoadError [Text] Problem -- ^ path to problem and problem description - deriving (Eq, Ord, Read, Show) +data LoadError = LoadError Position [Text] Problem -- ^ position, path, problem + deriving (Read, Show) -- | Run the Load computation until it produces a result or terminates @@ -161,9 +173,9 @@ -- | Problems that can be encountered when matching a 'Value' against a 'ValueSpecs'. data Problem - = MissingSection Text -- ^ missing section name - | UnusedSections [Text] -- ^ unused section names - | SpecMismatch Text -- ^ failed specification name + = 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. @@ -171,10 +183,10 @@ scope key (MkLoad m) = MkLoad (local (key:) m) -- | Abort value specification matching with the given error. -loadFail :: Problem -> Load a -loadFail cause = MkLoad $ +loadFail :: Position -> Problem -> Load a +loadFail pos cause = MkLoad $ do path <- ask - lift (throwE (pure (LoadError (reverse path) cause))) + lift (throwE (pure (LoadError pos (reverse path) cause))) ------------------------------------------------------------------------ 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,5 +1,5 @@ {-# Language FlexibleInstances, RankNTypes, GADTs, KindSignatures #-} -{-# Language GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# Language DeriveFunctor, GeneralizedNewtypeDeriving, OverloadedStrings #-} {-| Module : Config.Schema.Spec @@ -22,16 +22,17 @@ module Config.Schema.Spec ( -- * Specifying sections - SectionSpecs(..) + SectionSpecs , reqSection , optSection , reqSection' , optSection' -- * Specifying values - , ValueSpecs(..) + , ValueSpecs , Spec(..) , sectionsSpec + , assocSpec , atomSpec , anyAtomSpec , listSpec @@ -63,11 +64,12 @@ import Control.Applicative.Free (Ap, runAp, runAp_, liftAp) import Data.Functor.Const (Const(..)) -import Data.Functor.Coyoneda (Coyoneda(..), liftCoyoneda, lowerCoyoneda) -import Data.Functor.Compose (Compose(..), getCompose) +import Data.Functor.Coyoneda (Coyoneda(..), liftCoyoneda, lowerCoyoneda, hoistCoyoneda) import Data.Functor.Alt (Alt(..)) 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 @@ -98,7 +100,7 @@ -- | Lift a single specification into a list of specifications. -- --- @since 0.1.1.0 +-- @since 0.2.0.0 liftSectionSpec :: SectionSpec a -> SectionSpecs a liftSectionSpec = MkSectionSpecs . liftAp @@ -144,10 +146,10 @@ -- | Specification for a required section with an explicit value specification. reqSection' :: Text {- ^ section name -} -> - Text {- ^ description -} -> ValueSpecs a {- ^ value specification -} -> + Text {- ^ description -} -> SectionSpecs a -reqSection' n i w = liftSectionSpec (ReqSection n i w) +reqSection' n w i = liftSectionSpec (ReqSection n i w) -- | Specification for an optional section with an implicit value specification. @@ -162,10 +164,10 @@ -- | Specification for an optional section with an explicit value specification. optSection' :: Text {- ^ section name -} -> - Text {- ^ description -} -> ValueSpecs a {- ^ value specification -} -> + Text {- ^ description -} -> SectionSpecs (Maybe a) -optSection' n i w = liftSectionSpec (OptSection n i w) +optSection' n w i = liftSectionSpec (OptSection n i w) ------------------------------------------------------------------------ @@ -196,6 +198,10 @@ -- | 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 @@ -203,38 +209,49 @@ 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. -- -- Multiple specifications can be combined using this type's 'Alt' instance. -newtype ValueSpecs a = MkValueSpecs { unValueSpecs :: Compose NonEmpty (Coyoneda ValueSpec) a } - deriving Functor +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. --- --- Unlike 'runValueSpecs_', this allows the result of the interpretation to be indexed --- by the type of the primitive value specifications. -runValueSpecs :: Functor f => (forall x. ValueSpec x -> f x) -> ValueSpecs a -> NonEmpty (f a) -runValueSpecs f = fmap (lowerCoyoneda . hoistCoyoneda f) . getCompose . unValueSpecs +-- 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. -runValueSpecs_ :: (forall x. ValueSpec x -> m) -> ValueSpecs a -> NonEmpty m -runValueSpecs_ f = fmap getConst . runValueSpecs (Const . f) +-- 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'. -- --- @since 0.1.1.0 +-- @since 0.2.0.0 liftValueSpec :: ValueSpec a -> ValueSpecs a -liftValueSpec = MkValueSpecs . Compose . pure . liftCoyoneda +liftValueSpec = MkValueSpecs . pure . liftCoyoneda ------------------------------------------------------------------------ @@ -271,7 +288,7 @@ -- | Specification for matching any fractional number. -- --- @since 0.1.1.0 +-- @since 0.2.0.0 fractionalSpec :: Fractional a => ValueSpecs a fractionalSpec = fromRational <$> valuesSpec @@ -291,6 +308,17 @@ sectionsSpec i s = liftValueSpec (SectionSpecs i s) +-- | Specification for a section list where the keys are user-defined. +-- Values are matched against the underlying specification and returned +-- as a list of section-name\/value pairs. +-- +-- @since 0.3.0.0 +assocSpec :: + ValueSpecs a {- ^ underlying specification -} -> + ValueSpecs [(Text,a)] +assocSpec = liftValueSpec . AssocSpec + + -- | Named value specification. This is useful for factoring complicated -- value specifications out in the documentation to avoid repetition of -- complex specifications. @@ -324,19 +352,12 @@ -- | Matches a non-empty list. -- --- @since 0.1.1.0 +-- @since 0.2.0.0 nonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a) nonemptySpec s = customSpec "nonempty" (listSpec s) NonEmpty.nonEmpty -- | Matches a single element or a non-empty list. -- --- @since 0.1.1.0 +-- @since 0.2.0.0 oneOrNonemptySpec :: ValueSpecs a -> ValueSpecs (NonEmpty a) oneOrNonemptySpec s = pure <$> s nonemptySpec s - ------------------------------------------------------------------------- - --- | Lift a natural transformation to be a natural transformation of --- 'Coyoneda'. -hoistCoyoneda :: (forall x. f x -> g x) -> (Coyoneda f a -> Coyoneda g a) -hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,151 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Main +Description : Unit tests for config-schema +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com +-} +module Main (main) where + +import Config +import Config.Schema +import Control.Applicative +import Data.Foldable +import Data.Text (Text) +import qualified Data.Text as Text + +-- tests that are expected to pass. +-- +-- The input sources are a list of lists of lines. Each outer list +-- element contains a list of lines representing a complete input +-- source. Each of these variations must pass the test. +test :: + Show a => + Eq a => + ValueSpecs a {- ^ specification to match -} -> + a {- ^ expected output -} -> + [[Text]] {- ^ inputs sources -} -> + IO () +test spec expected txtss = + for_ txtss $ \txts -> + case parse (Text.unlines txts) of + Left e -> fail (show e) + Right v -> + case loadValue spec v of + Left e -> fail (show e) + Right x | x == expected -> return () + | otherwise -> fail ("Got " ++ show x ++ " but expected " ++ + show expected) + +main :: IO () +main = sequenceA_ + + [ test valuesSpec ("Hello world"::Text) + [["\"Hello world\""] + ,["\"H\\101l\\&l\\o157 \\" + ," \\w\\x6frld\""] + ] + + , test valuesSpec (1234::Integer) + [["1234"] + ,["1234.0"] + ] + + , test valuesSpec (0.65::Rational) + [["0.65e0"] + ,["65e-2"] + ,["6.5e-1"] + ,["0.65"] + ] + + , test anyAtomSpec "default" + [["default"]] + + , test (atomSpec "testing-1-2-3") () + [["testing-1-2-3"]] + + , test (listSpec valuesSpec) ([]::[Integer]) + [["[]"] + ,["[ ]"]] + + , test (listSpec anyAtomSpec) ["ḿyatoḿ"] + [["[ḿyatoḿ]"] + ,[" [ ḿyatoḿ ] "] + ,["* ḿyatoḿ"] + ] + + , test valuesSpec [1,2,3::Int] + [["[1,2,3]"] + ,["[1,2,3,]"] + ,["* 1" + ,"* 2" + ,"* 3"] + ] + + , test (listSpec valuesSpec) [[1,2],[3,4::Int]] + [["[[1,2,],[3,4]]"] + ,["*[1,2]" + ,"*[3,4]"] + ,["**1" + ," *2" + ,"* *3" + ," *4" + ] + ] + + , test (assocSpec valuesSpec) ([]::[(Text,Int)]) + [["{}"] + ,["{ }"] + ] + + , test (assocSpec valuesSpec) [("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) ] + [["[1, \"two\"]"] + ,["* 1" + ,"* \"two\""] + ] + + , test (sectionsSpec "test" + (liftA2 (,) (reqSection "k1" "") (reqSection "k2" ""))) + (10 :: Int, 20 :: Int) + [["k1: 10" + ,"k2: 20"] + ,["k2: 20" + ,"k1: 10"] + ] + + , test (sectionsSpec "test" + (liftA2 (,) (optSection "k1" "") (reqSection "k2" ""))) + (Just 10 :: Maybe Int, 20 :: Int) + [["k1: 10" + ,"k2: 20"] + ,["k2: 20" + ,"k1: 10"] + ] + + , test (sectionsSpec "test" + (liftA2 (,) (optSection "k1" "") (reqSection "k2" ""))) + (Nothing :: Maybe Int, 20 :: Int) + [["k2: 20"] + ,["{k2: 20}"] + ] + + -- This isn't a good idea, but it currently works + , test (sectionsSpec "test" + (liftA2 (,) (reqSection "k1" "") (reqSection "k1" ""))) + ("first"::Text, 50::Int) + [["k1: \"first\"" + ,"k1: 50"] + ] + + , test (sectionsSpec "test" (pure ())) () + [["{}"] + ] + ]