yaml-config 0.3.0 → 0.4.0

raw patch · 3 files changed

+77/−73 lines, 3 filesdep −failurePVP ok

version bump matches the API change (PVP)

Dependencies removed: failure

API changes (from Hackage documentation)

Files

• src/Data/Yaml/Config/Internal.hs +42/−34
• tests/Tests.hs +28/−29
• yaml-config.cabal +7/−10

@@ -1,17 +1,18 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Yaml.Config.Internal-    ( Config(..)+    (+    -- * Types+      Config(..)     , KeyError(..)     , Key -    -- * Work with files+    -- * Loading     , load -    -- * Explore config+    -- * Access functions     , keys     , subconfig     , lookup@@ -19,20 +20,19 @@     , fullpath     ) where -import Prelude hiding (lookup)-import Control.DeepSeq (NFData(rnf))-import Control.Exception (Exception)+import Control.DeepSeq (NFData (rnf))+import Control.Exception (Exception, throw) import Control.Monad (foldM) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-import Data.Typeable (Typeable) import qualified Data.Text as ST+import Data.Typeable (Typeable)+import Prelude hiding (lookup) -import Data.Yaml (Object, FromJSON(parseJSON), parseMaybe) import qualified Data.HashMap.Strict as HashMap+import Data.Yaml (FromJSON (parseJSON), Object, parseMaybe) import qualified Data.Yaml as Yaml import qualified Data.Yaml.Include as YamlInclude-import Control.Failure  -- | Config or field name type Key = ST.Text@@ -50,20 +50,21 @@ instance NFData Config where     rnf (Config p o) = rnf p `seq` rnf o `seq` () -ke :: Failure KeyError m => Key -> m a-ke = failure . KeyError+ke :: Monad m => Key -> m a+ke = throw . KeyError --- | Show full path from the root to target key. Levels are separated by dots.+-- | Returns full path from the root to the given key.+-- Levels are separated by dots. -- -- >>> fullpath sub "field1" -- "section1.field1" -- fullpath :: Config -> Key -> Key-fullpath (Config parents _) path = ST.intercalate "." $-    reverse $ path : parents+fullpath (Config parents _) path =+    ST.intercalate "." $ reverse (path : parents) --- | Find file in filesystem and try to load it as YAML config.--- May fail with @InvalidYaml@ if file not found.+-- | Attempts to load a config from a given YAML file.+-- Fails with @InvalidYaml@ if the file does not exist. -- -- >>> config <- load "example.yaml" --@@ -72,7 +73,7 @@   where     err = error $ "Invalid config file " <> f <> "." --- | Show all first level config field's.+-- | Returns all toplevel keys in a config. -- -- >>> keys config -- ["section1","section2"]@@ -80,22 +81,29 @@ keys :: Config -> [Key] keys (Config _ o) = HashMap.keys o --- | Get value for given key.--- May fail with @KeyError@ if key doesn't exist.+-- | Returns a value for a given key.+-- Fails with a @KeyError@ if the key doesn't exist. -- -- >>> keys sub -- ["field1","field2"] -- >>> putStrLn =<< lookup "field1" sub -- value1 ---lookup :: (Failure KeyError m, FromJSON a)-       => Key                               -- ^ Field name-       -> Config                            -- ^ Config for find-       -> m a                               -- ^ Field value+lookup :: (Monad m, FromJSON a)+       => Key                   -- ^ Field name+       -> Config                -- ^ Config to query+       -> m a                   -- ^ Looked up value lookup path c = maybe err return $ lookupMaybe path c   where     err = ke $ "Field " <> fullpath c path <> " not found or has wrong type." +-- | An exception-free alternative to @lookup@.+--+-- >>> keys sub+-- ["field1","field2"]+-- >>> lookupMaybe "field1" sub+-- Just "value1"+-- lookupMaybe :: FromJSON a => Key -> Config -> Maybe a lookupMaybe path conf = foldM (flip subconfig) conf (init pathes) >>=     look (last pathes)@@ -103,28 +111,28 @@     look k (Config _ o) = HashMap.lookup k o >>= parseMaybe parseJSON     pathes = ST.splitOn "." path --- | Find value in config and return it or return default value.+-- | Returns a value for a given key or a default value if a key doesn't exist. -- -- >>> lookupDefault "field3" "def" sub -- "def" -- lookupDefault :: FromJSON a-              => Key         -- ^ Field name-              -> a           -- ^ Default value-              -> Config      -- ^ Config for find-              -> a           -- ^ Founded or default value+              => Key            -- ^ Field name+              -> a              -- ^ Default value+              -> Config         -- ^ Config to query+              -> a              -- ^ Looked up or default value lookupDefault p d = fromMaybe d . lookup p --- | Get subconfig by name.--- May fail with @KeyError@ if target key doesn't exist at current level.+-- | Narrows into a config section corresponding to a given key.+-- Fails with a @KeyError@ if a key doesn't exist at the current level. -- -- >>> :set -XOverloadedStrings -- >>> sub <- subconfig "section1" config ---subconfig :: Failure KeyError m+subconfig :: Monad m           => Key                 -- ^ Subconfig name-          -> Config              -- ^ (Sub)Config for find-          -> m Config            -- ^ Founded Subconfig+          -> Config              -- ^ (Sub)Config to narrow into+          -> m Config            -- ^ Subconfig subconfig path c@(Config parents o) = case HashMap.lookup path o of     Just (Yaml.Object so) -> return $ Config (path : parents) so     _                     -> err

@@ -3,23 +3,18 @@ module Main where  import Control.Monad (liftM)-import Data.Monoid ((<>))-import Data.Hashable (Hashable)-import Data.Text (Text) import Data.List as List+import Data.Monoid ((<>)) import Data.Text as Text-import qualified Data.Text as ST -import Test.Tasty (defaultMain, testGroup)-import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck (Gen, Property, Arbitrary(..), elements, sized, oneof,-                        listOf)-import Test.QuickCheck.Monadic (assert)-import Data.Yaml(Object, Value(Object, Null)) import qualified Data.HashMap.Strict as HashMap+import Data.Yaml (Object, Value (Object))+import Test.QuickCheck (Arbitrary (..), Gen, expectFailure, sized)+import Test.QuickCheck.Monadic (monadicIO, run)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (Property, testProperty) -import Data.Yaml.Config.Internal (Config(Config), Key, subconfig, keys,-                                  fullpath)+import Data.Yaml.Config.Internal (Config (Config), Key, fullpath, keys, subconfig)  type CorrectPath = [Key] @@ -35,46 +30,50 @@ newObject = HashMap.fromList  deepConfig :: Gen DeepObject-deepConfig = sized deepConfig' >>= \(keys, obj) ->-    return $ DeepObject (Config [] obj) $ List.tail keys+deepConfig = sized deepConfig' >>= \(ks, obj) ->+    return $ DeepObject (Config [] obj) $ List.tail ks  deepConfig' :: Int -> Gen ([Key], Object)-deepConfig' 0 = arbitrary >>= \newKey -> return $ ([newKey], newObject [])+deepConfig' 0 = arbitrary >>= \newKey -> return ([newKey], newObject []) deepConfig' n | n > 0 = do     newKey <- arbitrary-    (keys, newNode) <- deepConfig' (pred n)-    return $ (newKey : keys, newObject [(List.head keys , Object newNode)])+    (ks, newNode) <- deepConfig' (pred n)+    return (newKey : ks, newObject [(List.head ks , Object newNode)])  testCorrectSubconfigPath :: DeepObject -> Bool testCorrectSubconfigPath (DeepObject _ []) = True testCorrectSubconfigPath (DeepObject config (key : others)) =     maybe False (`subcheck` others) $ subconfig key config   where-    subcheck sc keys = testCorrectSubconfigPath $ DeepObject sc keys+    subcheck sc = testCorrectSubconfigPath . DeepObject sc -testWrongSubconfigPath :: DeepObject -> Bool-testWrongSubconfigPath (DeepObject config []) = List.null $ keys config+testWrongSubconfigPath' :: DeepObject -> Property+testWrongSubconfigPath' = expectFailure . monadicIO . run . testWrongSubconfigPath++testWrongSubconfigPath :: DeepObject -> IO Bool+testWrongSubconfigPath (DeepObject config []) = return . List.null $ keys config testWrongSubconfigPath (DeepObject config (nextKey : others)) =-    maybe nextCheck (const False) $ subconfig wrongKey config+    maybe nextCheck (const $ return False) $ subconfig wrongKey config   where-    nextCheck = maybe False (testWrongSubconfigPath . nextDeep) $+    nextCheck = maybe (return False) (testWrongSubconfigPath . nextDeep) $         subconfig nextKey config     nextDeep = flip DeepObject others     wrongKey = nextKey <> "_"  testCorrectPath :: DeepObject -> Bool testCorrectPath = testCorrectPath' []-testCorrectPath' path (DeepObject config (nextKey : others)) = checkPath config-    && (maybe False (`subcheck` others) $ subconfig nextKey config)   where-    subcheck sc keys = testCorrectPath' (nextKey : path) $ DeepObject sc keys-    checkPath c = fullpath c nextKey ==-                  (ST.intercalate "." $ List.reverse $ nextKey : path)-testCorrectPath' _ (DeepObject config []) = List.null $ keys config+    testCorrectPath' path (DeepObject config (nextKey : others)) = checkPath config+        && maybe False (`subcheck` others) (subconfig nextKey config)+      where+        subcheck sc = testCorrectPath' (nextKey : path) . DeepObject sc+        checkPath c = fullpath c nextKey ==+            Text.intercalate "." (List.reverse $ nextKey : path)+    testCorrectPath' _ (DeepObject config []) = List.null $ keys config  main :: IO () main = defaultMain $ testGroup "Tests"-    [ testProperty "wrongSubconfigPath" testWrongSubconfigPath+    [ testProperty "wrongSubconfigPath" testWrongSubconfigPath'     , testProperty "correctSubconfigPath" testCorrectSubconfigPath     , testProperty "correctPath" testCorrectPath     ]

@@ -1,5 +1,5 @@ Name:               yaml-config-Version:            0.3.0+Version:            0.4.0 Synopsis:           Configuration management Description:        Configuration management License:            MIT@@ -20,10 +20,9 @@   Ghc-options:      -Wall -fno-warn-orphans   Build-depends:    base                       >= 4.5.0 && < 5.0.0                   , deepseq                    >= 1.3-                  , unordered-containers       >= 0.2.0                   , text                       >= 0.11.0+                  , unordered-containers       >= 0.2.0                   , yaml                       >= 0.8.10-                  , failure                    >= 0.2.0    Exposed-modules:  Data.Yaml.Config                     Data.Yaml.Config.Internal@@ -34,17 +33,15 @@   Default-language: Haskell2010   Type:             exitcode-stdio-1.0 -  Build-depends:    base                       >= 4.5.0 && < 5.0.0+  Build-depends:    QuickCheck                 >= 2.6.0+                  , base                       >= 4.5.0 && < 5.0.0                   , deepseq                    >= 1.3-                  , unordered-containers       >= 0.2.0-                  , text                       >= 0.11.0-                  , yaml                       >= 0.8.10-                  , failure                    >= 0.2.0-                   , hashable                   >= 1.2.0                   , tasty                      >= 0.10.0                   , tasty-quickcheck           >= 0.8.0-                  , QuickCheck                 >= 2.6.0+                  , text                       >= 0.11.0+                  , unordered-containers       >= 0.2.0+                  , yaml                       >= 0.8.10  Source-repository head     Type:     git