aeson-commit (empty) → 1.0
raw patch · 4 files changed
+207/−0 lines, 4 filesdep +aesondep +aeson-commitdep +aeson-qq
Dependencies added: aeson, aeson-commit, aeson-qq, base, containers, hspec, mtl, some, tasty, tasty-hspec, text, transformers
Files
- README.md +6/−0
- aeson-commit.cabal +48/−0
- src/Data/Aeson/Commit.hs +96/−0
- test/tasty/Main.hs +57/−0
+ README.md view
@@ -0,0 +1,6 @@+# aeson-commit++## Parse Aeson data with commitment++Aeson parsers backtracks too much for some use cases. The commit+parser forbids backtracking for already committed parses.
+ aeson-commit.cabal view
@@ -0,0 +1,48 @@+cabal-version: >=1.10+name: aeson-commit+version: 1.0+license: BSD3+copyright: 2020 Cross Compass Ltd.+maintainer: jonascarpay@gmail.com+author:+ Viktor Kronvall <viktor.kronvall@cross-compass.com>, Jonas Carpay <jonascarpay@gmail.com>++synopsis: Parse Aeson data with commitment+description:+ Aeson parsers backtracks too much for some use cases.+ The commit parser forbids backtracking for already committed parses.++category: Web+build-type: Simple+extra-source-files: README.md++library+ exposed-modules: Data.Aeson.Commit+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wno-name-shadowing+ build-depends:+ aeson >=1.5.4.1 && <2+ , base >=4.13.0.0 && <5+ , mtl >=2.2.2 && <3+ , text >=1.2.4.0 && <2++test-suite tasty+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test/tasty+ default-language: Haskell2010+ ghc-options: -Wall -Wno-name-shadowing+ build-depends:+ aeson >=1.5.4.1 && <2+ , aeson-commit+ , aeson-qq >=0.8.3 && <1+ , base >=4.13.0.0 && <5+ , containers >=0.6.2.1 && <1+ , hspec >=2.7.4 && <3+ , mtl >=2.2.2 && <3+ , some >=1.0.1 && <2+ , tasty >=1.3.1 && <2+ , tasty-hspec >=1.1.5.1 && <2+ , text >=1.2.4.0 && <2+ , transformers >=0.5.6.2 && <1
+ src/Data/Aeson/Commit.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+ Commitment mechanism for aeson parsers.+ This is comes up when you e.g. want to make a distinction between missing keys and malformed keys.+ As an example, this parser will look for a key @"nested"@, and if present try to read the embedded @"value"@, or alternatively look for a top level @"value"@:++ > parse o = (o .:> "nested") (withObject "nestedObj" (.: "value"))+ > <|> tryParser (o .: "value")++ > { value: "foo", otherField: "bar" }+ > -> Right "foo"+ >+ > { value: "foo", nested: { value: "bar" } }+ > -> Right "bar"+ >+ > { value: "foo", nested: { bar: 9 } }+ > -> Left "Error in $.nested: key \"value\" not found"+ >+ > { value: "foo", nested: 9 }+ > -> Left "Error in $.nested: parsing nestedObj failed, expected Object, but encountered Number"+ >+ > {}+ > -> Left+ > "Error in $: No match,+ > - key \"value\" not found"+ > - key \"nested\" not found"++-}+module Data.Aeson.Commit where++import Control.Applicative (Alternative (..))+import Control.Monad.Except+import Data.Aeson.Types+import Data.Text (Text)+import Data.Void (Void, absurd)++-- | A 'Parser' that has _two_ failure modes; recoverable and non-recoverable.+-- The default, recoverable failure is the equivalent to aeson's default 'Parser' behavior.+-- The non-recoverable failure mode is used to commit to a branch; to commit means that every subsequent failure is non-recoverable.+--+-- You turn a commit back into a normal 'Parser' using 'runCommit'.+-- As an additional benefit, if no commit succeeded the parser error message will contain all encountered errors.+--+-- The implementation works by capturing failure in either the 'ExceptT' or in the underlying 'Parser'.+-- The derived 'Alternative' instance will only recover from failures in the 'ExceptT'.+-- This means that as soon as we successfully construct a 'Right' value, the 'Alternative' considers the 'Commit' a success, even though the underlying parser might have failed.+-- The 'Void' represents the guarantee that we only collect error values.+newtype Commit a = Commit {unCommit :: ExceptT [Parser Void] Parser a}+ deriving (Monad, Functor, Applicative, Alternative)++-- | Construct a commit.+-- If the first parser succeeds, the 'Commit' is a success, and any failures in the inner action will be preserved.+commit :: Parser a -> (a -> Parser b) -> Commit b+commit pre post = Commit $ do+ a <- ExceptT $ captureError pre+ lift $ post a+ where+ captureError :: Parser b -> Parser (Either [Parser Void] b)+ captureError p = Right <$> p <|> pure (Left [fmap (const undefined) p])++-- | Recommended way of turning a 'Commit' back into a regular 'Parser'.+runCommit :: Commit a -> Parser a+runCommit (Commit f) = runExceptT f >>= either handleErrors pure+ where+ handleErrors :: [Parser Void] -> Parser a+ handleErrors [] = fail "No parsers tried"+ handleErrors (p:ps) = fmap absurd (go (p:ps) [] [])+ where+ go [] path errors = parserThrowError path ("No match,\n" <> unlines (fmap ("- " <>) errors))+ go (y:ys) _ msgs = parserCatchError y $ \path msg ->+ go ys path (msg:msgs)+ -- TODO: how do we handle the multiple JSONPaths?+ -- Right now the rightmost failure's path is used when presenting+ -- the error message. Ideally one path per error would be preferable but+ -- `aeson` doesn't support such a thing. When errors are reported in `aeson`+ -- a single JSONPath defines how the error message is presented.++-- | Convenience wrapper around 'commit' for when the commit is checking whether a key is present in some object.+-- If it is, it will commit and append the key to the JSONPath of the inner context through '<?>', which will give nicer error messages.+(.:>) :: FromJSON a => Object -> Text -> (a -> Parser b) -> Commit b+(o .:> k) cont = commit (o .: k) (\v -> cont v <?> Key k)++-- | Try to parse with a 'Parser' and commit if it parses successfully.+-- Unlike 'liftParser', the parser's failure is recoverable.+-- +-- > tryParser empty <|> p = p+tryParser :: Parser a -> Commit a+tryParser p = commit p pure++-- | Turn a 'Parser' into a 'Commit'.+-- Unlike 'tryParser', the parser's failure is _not_ recoverable, i.e. the parse is always committed.+-- +-- > liftParser empty <|> p = empty+liftParser :: Parser a -> Commit a+liftParser p = commit (pure ()) (const p)
+ test/tasty/Main.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Data.Aeson.QQ+import Data.Aeson.Types+import Data.Aeson.Commit+import Control.Applicative+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.Hspec++tests :: Spec+tests = testParserWithCases pNested+ [ ( "fails"+ , [aesonQQ| {} |]+ , Left $ unlines+ [ "Error in $: No match,"+ , "- key \"value\" not found"+ , "- key \"nested\" not found"+ ]+ )+ , ( "succeeds unnested"+ , [aesonQQ| { value: "top" } |]+ , Right "top"+ )+ , ( "succeeds and prefers nested"+ , [aesonQQ| { value: "top" , nested: { value: "nest" } } |]+ , Right "nest"+ )+ , ( "fails on malformed nested"+ , [aesonQQ| { value: "top", nested: { foo: 9 } } |]+ , Left "Error in $.nested: key \"value\" not found"+ )+ , ( "fails on nested type mismatch"+ , [aesonQQ| { value: "top", nested: 9 } |]+ , Left "Error in $.nested: parsing nestedObj failed, expected Object, but encountered Number"+ )+ ]+ where+ pNested :: Value -> Parser Text+ pNested = withObject "topLevel" $ \o ->+ runCommit+ $ (o .:> "nested") (withObject "nestedObj" (.: "value"))+ <|> tryParser (o .: "value")++testParserWithCases+ :: (Eq a, Show a)+ => (v -> Parser a)+ -> [(String, v, Either String a)]+ -> Spec+testParserWithCases p =+ mapM_ ( \(name, v, result) -> it name (parseEither p v `shouldBe` result))++main :: IO ()+main = testSpecs tests >>= defaultMain . testGroup "aeson-commit"