yaml-combinators 1.1.1.2 → 1.1.2

raw patch · 4 files changed

+140/−29 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• src/Data/Yaml/Combinators.hs +96/−27
• src/Data/Yaml/Combinators/Free.hs +37/−0
• yaml-combinators.cabal +3/−2

@@ -1,5 +1,9 @@ # Revision history for yaml-combinators +## 1.1.2++* Add an `extraFields` combinator+ ## 1.1.1.2  * Drop support for old GHCs

@@ -4,7 +4,7 @@ {-# LANGUAGE PolyKinds, DataKinds, KindSignatures,              ExplicitForAll, TemplateHaskell, ViewPatterns,              ScopedTypeVariables, TypeOperators, TypeFamilies,-             GeneralizedNewtypeDeriving #-}+             GeneralizedNewtypeDeriving, GADTs, LambdaCase #-} module Data.Yaml.Combinators   ( Parser   , parse@@ -28,6 +28,8 @@   , optField   , defaultField   , theField+  , extraFields+  -- * Arbitrary values   , anyValue   -- * Errors   , ParseError(..)@@ -45,19 +47,19 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import Data.Bifunctor (first)+import Control.Monad import Control.Monad.Trans.Reader import Control.Monad.Trans.State as State import Data.Vector (Vector) import qualified Data.Vector as V-import Data.Functor.Product-import Data.Functor.Constant-import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.Ord+import Data.Monoid import Generics.SOP import Generics.SOP.TH+import Data.Yaml.Combinators.Free as Free  -- $setup -- >>> :set -XOverloadedStrings -XTypeApplications@@ -412,36 +414,37 @@ -- -- * Turn a 'FieldParser' into a 'Parser' with 'object'. newtype FieldParser a = FieldParser-  (Product-    (ReaderT Object Validation)-    (Constant (HashMap Text ())) a)+  (Free FieldParserBase a)   deriving (Functor, Applicative) +data FieldParserBase a where+  OneField+    :: Text -- ^ field name+    -> ReaderT Object Validation a+    -> FieldParserBase a+  ExtraFields :: FieldParserBase Object+ -- | Require an object field with the given name and with a value matched by -- the given 'Parser'. field   :: Text -- ^ field name   -> Parser a -- ^ value parser   -> FieldParser a-field name p = FieldParser $-  Pair-    (ReaderT $ \o ->-      case HM.lookup name o of-        Nothing -> Validation . Left $ ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "field " ++ show name) $ Object o-        Just v -> runParserV p v-    )-    (Constant $ HM.singleton name ())+field name p = FieldParser . Free.lift . OneField name $+  ReaderT $ \o ->+    case HM.lookup name o of+      Nothing -> Validation . Left $ ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "field " ++ show name) $ Object o+      Just v -> runParserV p v + -- | Declare an optional object field with the given name and with a value -- matched by the given 'Parser'. optField   :: Text -- ^ field name   -> Parser a -- ^ value parser   -> FieldParser (Maybe a)-optField name p = FieldParser $-  Pair-    (ReaderT $ \o -> traverse (runParserV p) $ HM.lookup name o)-    (Constant $ HM.singleton name ())+optField name p = FieldParser . Free.lift . OneField name $+  ReaderT $ \o -> traverse (runParserV p) $ HM.lookup name o  -- | Declare an optional object field with the given name and with a default -- to use if the field is absent.@@ -472,6 +475,43 @@   -> FieldParser () theField key value = field key (theString value) +-- | This combinator does two things:+--+-- 1. Allow extra fields (not specified by 'field', 'theField' etc.) in the+-- parsed object.+-- 2. Return such extra fields as an 'Object'.+--+-- The return value can be of course ignored.+--+-- >>> let fp = field "name" string+-- >>> either putStr print $ parse (object fp) "name: Anton"+-- "Anton"+-- >>> either putStr print $ parse (object fp) "{name: Anton, age: 2}"+-- Unexpected+-- <BLANKLINE>+-- age: 2+-- <BLANKLINE>+-- as part of+-- <BLANKLINE>+-- age: 2+-- name: Anton+-- >>> either putStr print $ parse (object $ (,) <$> fp <*> extraFields) "{name: Anton, age: 2}"+-- ("Anton",fromList [("age",Number 2.0)])+-- >>> either putStr print $ parse (object $ fp <* extraFields) "{name: Anton, age: 2}"+-- "Anton"+--+-- @since 1.1.2+extraFields :: FieldParser Object+extraFields = FieldParser . Free.lift $ ExtraFields++data StrictPair a b = StrictPair !a !b++instance (Semigroup a, Semigroup b) => Semigroup (StrictPair a b) where+  StrictPair a1 b1 <> StrictPair a2 b2 = StrictPair (a1 <> a2) (b1 <> b2)++instance (Monoid a, Monoid b) => Monoid (StrictPair a b) where+  mempty = StrictPair mempty mempty+ -- | Match an object. Which set of keys to expect and how their values -- should be parsed is determined by the 'FieldParser'. --@@ -480,16 +520,45 @@ -- Right ("Anton",Just 2) -- >>> parse p "name: Roma" -- Right ("Roma",Nothing)+--+-- By default, this function will fail when there are unrecognized fields+-- in the object. See 'extraFields' for a way to capture or ignore them. object :: FieldParser a -> Parser a-object (FieldParser (Pair (ReaderT parseFn) (Constant names))) = fromComponent $ Z $ ParserComponent $ Just $ const $ \(I o :* Nil) ->+object (FieldParser fp) = fromComponent $ Z $ ParserComponent $ Just $ const $ \(I o :* Nil) ->   incErrLevel $-    parseFn o <*-    (case HM.keys (HM.difference o names) of-      [] -> pure ()-      name : _ ->-        let v = o HM.! name-        in Validation . Left $ ParseError 0 $ UnexpectedAsPartOf (Object (HM.singleton name v)) (Object o)-    )+    let+      -- Do a first run over the free FieldParser applicative to collect+      -- some metainformation: which fields are requested by the parser,+      -- and whether extra fields are requested too (and therefore allowed)+      StrictPair requested_names (Any requested_extra_fields) = Free.foldMap (\case+        OneField name _ -> StrictPair (HM.singleton name ()) (Any False)+        ExtraFields -> StrictPair mempty (Any True)+        ) fp+      extra_fields = HM.difference o requested_names+      extra_fields_error =+        when (not requested_extra_fields && not (HM.null extra_fields)) $+          Validation . Left $ ParseError 0 $+            UnexpectedAsPartOf (Object extra_fields) (Object o)+    in+      Free.run (\case+        OneField _ p -> runReaderT p o+        ExtraFields -> pure extra_fields+        ) fp+        -- See Note [Extra fields error]+        <* extra_fields_error++{- Note [Extra fields error]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+   We could have written++     if not requested_extra_fields && not (HM.null extra_fields)+        then Validation . Left $  ...+        else ...++   However, we intentionally try to run the applicative parser even when+   there are extra fields, because some of the resulting validation errors+   may be more severe/interesting than the "extra fields" error.+-}  -- | Match any JSON value and return it as Aeson's 'Value'. --

@@ -0,0 +1,37 @@+-- | Twan van Laarhoven’s free applicative (see+-- <https://ro-che.info/articles/2013-03-31-flavours-of-free-applicative-functors>)+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}+module Data.Yaml.Combinators.Free where++data Free f a where+  Pure :: a -> Free f a+  Ap :: Free f (a -> b) -> f a -> Free f b++instance Functor (Free f) where+  fmap f (Pure x) = Pure $ f x+  fmap f (Ap tx ay) = Ap ((f .) <$> tx) ay++instance Applicative (Free f) where+  pure = Pure+  Pure f <*> tx = fmap f tx+  Ap tx ay <*> tz = Ap (flip <$> tx <*> tz) ay++lift :: f a -> Free f a+lift = Ap (Pure id)++-- | A strict, tail-recursive monoidal foldMap over a free applicative functor+foldMap :: forall a b f . Monoid b => (forall c . f c -> b) -> Free f a -> b+foldMap f free0 = go free0 mempty+  where+    go :: forall c . Free f c -> b -> b+    go free acc = case free of+      Pure _ -> acc+      Ap free' base -> go free' $! f base <> acc++run :: forall a f g . Applicative g => (forall c . f c -> g c) -> Free f a -> g a+run f = go+  where+    go :: forall c . Free f c -> g c+    go free = case free of+      Pure a -> pure a+      Ap free' base -> go free' <*> (f base)

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                yaml-combinators-version:             1.1.1.2+version:             1.1.2 synopsis:            YAML parsing combinators for improved validation and error reporting description:         Based on the article                      <https://ro-che.info/articles/2015-07-26-better-yaml-parsing Better Yaml Parsing>.@@ -27,7 +27,8 @@     Haskell2010   exposed-modules:     Data.Yaml.Combinators-  -- other-modules:+  other-modules:+    Data.Yaml.Combinators.Free   -- other-extensions:   build-depends:     aeson,