waargonaut 0.4.1.0 → 0.4.2.0

raw patch · 6 files changed

+185/−14 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• src/Waargonaut/Decode.hs +58/−8
• src/Waargonaut/Decode/Internal.hs +55/−2
• test/Decoder.hs +19/−2
• test/Main.hs +46/−1
• waargonaut.cabal +1/−1

@@ -1,5 +1,11 @@ # Revision history for waargonaut +## 0.4.2.0  -- 2018-11-29++* Improved pretty printing of CursorHistory by condensing multiple numeric movements and removing the single movements following searching for keys.+* Add `fromKeyOptional` and `atKeyOptional` that make it easier to handle optional keys on objects.+* Add `prismDOrFail'` function to allow the user to construct an error from the value that was decoded.+ ## 0.4.1.0  -- 2018-11-20  * Add `oneOf` decoder and tests

@@ -53,6 +53,10 @@   , atKey   , focus +    -- * Attempting decoding+  , fromKeyOptional+  , atKeyOptional+     -- * Provided Decoders   , leftwardCons   , rightwardSnoc@@ -85,10 +89,11 @@  import           Control.Lens                              (Cons, Lens', Prism',                                                             Snoc, cons, lens,-                                                            modifying, preview,-                                                            snoc, traverseOf,-                                                            view, ( # ), (.~),-                                                            (^.), _Wrapped)+                                                            matching, modifying,+                                                            preview, snoc,+                                                            traverseOf, view,+                                                            ( # ), (.~), (^.),+                                                            _Wrapped)  import           Prelude                                   (Bool, Bounded, Char,                                                             Eq, Int, Integral,@@ -98,10 +103,12 @@  import           Control.Applicative                       (Applicative (..)) import           Control.Category                          ((.))-import           Control.Monad                             (Monad (..), (>=>))+import           Control.Monad                             (Monad (..), (=<<),+                                                            (>=>)) import           Control.Monad.Morph                       (embed, generalize) -import           Control.Monad.Except                      (lift, liftEither,+import           Control.Monad.Except                      (catchError, lift,+                                                            liftEither,                                                             throwError) import           Control.Monad.Reader                      (ReaderT (..), ask,                                                             local, runReaderT)@@ -111,6 +118,7 @@ import           Control.Monad.Error.Hoist                 ((<!?>), (<?>))  import           Data.Either                               (Either (..))+import qualified Data.Either                               as Either (either) import           Data.Foldable                             (Foldable, foldl,                                                             foldr) import           Data.Function                             (const, flip, ($),@@ -481,6 +489,39 @@ atKey k d =   withCursor (down >=> fromKey k d) +-- | A version of 'fromKey' that returns its result in 'Maybe'. If the key is+-- not present in the object, 'Nothing' is returned. If the key is present,+-- decoding will be performed as with 'fromKey'.+--+-- For example, if a key could be absent and could be null if present,+-- it could be decoded as follows:+--+-- @+-- join <$> fromKeyOptional "key" (maybeOrNull text)+-- @+fromKeyOptional+  :: Monad f+  => Text+  -> Decoder f b+  -> JCurs+  -> DecodeResult f (Maybe b)+fromKeyOptional k d c =+  focus' =<< catchError (pure <$> moveToKey k c) (\de -> case de of+    KeyNotFound _ -> pure Nothing+    _             -> throwError de)+  where+    focus' = maybe (pure Nothing) (fmap Just . focus d)++-- | A version of 'atKey' that returns its result in 'Maybe'. If the key is+-- not present in the object, 'Nothing' is returned. If the key is present,+-- decoding will be performed as with 'atKey'.+atKeyOptional+  :: Monad f+  => Text+  -> Decoder f b+  -> Decoder f (Maybe b)+atKeyOptional k d = withCursor (down >=> fromKeyOptional k d)+ -- | Used internally in the construction of the basic 'Decoder's. Takes a 'Text' -- description of the thing you expect to find at the current cursor, and a -- function to convert the 'Json' structure found there into something else.@@ -702,8 +743,17 @@   -> Prism' a b   -> Decoder f a   -> Decoder f b-prismDOrFail e p d = withCursor $-  focus d >=> \a -> preview p a <?> e+prismDOrFail e = prismDOrFail' (const e)++-- | Like 'prismDOrFail'', but lets you use the @a@ to construct the error.+prismDOrFail'+  :: Monad f+  => (a -> DecodeError)+  -> Prism' a b+  -> Decoder f a+  -> Decoder f b+prismDOrFail' e p d = withCursor $+  focus d >=> Either.either (throwError . e) pure . matching p  -- | Decode an 'Int'. int :: Monad f => Decoder f Int

@@ -10,6 +10,8 @@ module Waargonaut.Decode.Internal   ( CursorHistory' (..)   , ppCursorHistory+  , compressHistory+   , DecodeResultT (..)   , Decoder' (..) @@ -47,7 +49,6 @@ import           Control.Lens                  (Rewrapped, Wrapped (..), (%=),                                                 _1, _Wrapped) import qualified Control.Lens                  as L- import           Control.Monad                 ((>=>)) import           Control.Monad.Except          (ExceptT (..), MonadError (..),                                                 liftEither, runExceptT)@@ -58,8 +59,10 @@ import           Control.Monad.Morph           (MFunctor (..), MMonad (..))  import           Data.Bifunctor                (first)+import qualified Data.Foldable                 as F import           Data.Functor                  (($>))-import           Data.Sequence                 (Seq)+import           Data.Semigroup                ((<>))+import           Data.Sequence                 (Seq, fromList)  import           Data.Text                     (Text) @@ -73,6 +76,8 @@ import           Data.Scientific               (Scientific) import qualified Data.Scientific               as Sci +import           Natural                       (Natural, _Natural)+ import           Waargonaut.Types              (AsJType (..), JString,                                                 jNumberToScientific,                                                 jsonAssocKey, jsonAssocVal,@@ -96,6 +101,53 @@   }   deriving (Show, Eq) +switchbackMoves+  :: (Natural -> a)+  -> (Natural -> a)+  -> Natural+  -> Natural+  -> b+  -> b+  -> [(a, b)]+  -> [(a, b)]+switchbackMoves a b n m i i' sq =+  let+    n' = _Natural L.# n :: Int+    m' = _Natural L.# m+  in+    if n' > m'+    then (a $ (n' - m') L.^. _Natural, i)  : sq+    else (b $ (m' - n') L.^. _Natural, i') : sq++rmKeyJumps :: [(ZipperMove, i)] -> [(ZipperMove, i)]+rmKeyJumps (d@(DAt _, _) : (R _, _) : sq) = d:sq+rmKeyJumps s                              = s++combineLRMoves :: [(ZipperMove, i)] -> [(ZipperMove, i)]+combineLRMoves ((R n, _) : (R m, i)  : sq) = (R (n <> m), i) : sq+combineLRMoves ((L n, _) : (L m, i)  : sq) = (L (n <> m), i) : sq+combineLRMoves ((L n, i) : (R m, i') : sq) = switchbackMoves L R n m i i' sq+combineLRMoves ((R n, i) : (L m, i') : sq) = switchbackMoves R L n m i i' sq+combineLRMoves s                           = s++-- | This function will condense incidental movements, reducing the amount of+-- noise in the error output.+--+-- The rules that are currently applied are:+--+-- * [R n, R m]   = [R (n + m)]+-- * [L n, R m]   = [L (n + m)]+-- * [R n, L m]   = [R (n - m)] where n > m+-- * [R n, L m]   = [L (m - n)] where n < m+-- * [L n, R m]   = [L (n - m)] where n > m+-- * [L n, R m]   = [R (m - n)] where n < m+-- * [DAt k, R n] = [DAt k]+--+-- This function is automatically applied when using the 'ppCursorHistory'+-- function to render the cursor movements.+compressHistory :: CursorHistory' i -> CursorHistory' i+compressHistory = L.over _Wrapped (fromList . L.transform (combineLRMoves . rmKeyJumps) . F.toList)+ -- | -- Pretty print the given 'CursorHistory'' to a more useful format compared to a 'Seq' of 'i'. ppCursorHistory@@ -105,6 +157,7 @@   foldr (<+>) mempty   . fmap (ppZipperMove . fst)   . unCursorHistory'+  . compressHistory  instance CursorHistory' i ~ t => Rewrapped (CursorHistory' i) t 

@@ -5,8 +5,8 @@   ( decoderTests   ) where -import           Prelude                    (Char, Eq, Int, Show, String, print,-                                             (==))+import           Prelude                    (Char, Eq, Int, Show (show), String,+                                             print, (==))  import           Control.Applicative        (liftA3, (<$>)) import           Control.Category           ((.))@@ -21,6 +21,8 @@ import qualified Data.Either                as Either import           Data.Function              (const, ($)) import           Data.Functor.Alt           ((<!>))+import           Data.Maybe                 (Maybe (Just, Nothing))+import           Data.Semigroup             (Semigroup ((<>))) import qualified Data.Sequence              as Seq import           Data.Tagged                (untag) import           Data.Text                  (Text)@@ -51,6 +53,7 @@   , testCase "Using Alt (Error) - Records BranchFail" decodeAltError   , testCase "List Decoder" listDecoder   , testCase "NonEmpty List Decoder" nonEmptyDecoder+  , testCase "Absent Key Decoder" absentKeyDecoder   ]  nonEmptyDecoder :: Assertion@@ -187,3 +190,17 @@                   )                  (\_ -> assertFailure "Alt Error Test should fail")++absentKeyDecoder :: Assertion+absentKeyDecoder = do+  a <- D.runDecode (D.atKeyOptional "key" D.text) parseBS (D.mkCursor "{\"key\":\"present\"}")+  b <- D.runDecode (D.atKeyOptional "missing" D.text) parseBS (D.mkCursor "{\"key\":\"present\"}")+  c <- D.runDecode (D.atKeyOptional "key" D.int) parseBS (D.mkCursor "{\"key\":\"present\"}")++  a @?= Either.Right (Just "present")+  b @?= Either.Right Nothing+  case c of+    Either.Right _ ->+      assertFailure "atKeyOptional succeeded when it shouldn't have"+    Either.Left (e, _) ->+      assertEqual ("atKeyOptional failed incorrectly: " <> show e) e (D.ConversionFailure "integral")

@@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-} module Main (main) where  import           Control.Lens                (( # ), (^.), (^?), _2) import qualified Control.Lens                as L+import           Control.Monad               (when)  import           Data.Either                 (isLeft) @@ -18,6 +20,8 @@ import           Data.Text                   (Text) import qualified Data.Text.Encoding          as Text +import qualified Data.Sequence               as S+ import           Hedgehog import qualified Hedgehog.Gen                as Gen import qualified Hedgehog.Range              as Range@@ -26,6 +30,8 @@ import           Test.Tasty.Hedgehog import           Test.Tasty.HUnit +import           Natural                     (_Natural)+ import           Data.Digit                  (HeXDigit)  import           Waargonaut                  (Json)@@ -40,6 +46,8 @@  import qualified Waargonaut.Decode           as D import           Waargonaut.Decode.Error     (DecodeError)+import           Waargonaut.Decode.Internal  (CursorHistory' (..),+                                              ZipperMove (..), compressHistory) import qualified Waargonaut.Encode           as E  import           Waargonaut.Generic          (mkDecoder, mkEncoder)@@ -75,6 +83,42 @@ decode =   Common.parseText +prop_history_condense :: Property+prop_history_condense = property $ do+  n <- forAll $ Gen.int (Range.linear 1 10)+  m <- forAll $ Gen.int (Range.linear 1 10)++  let+    ixa = 1 :: Int+    ixb = 2+    mkCH = CursorHistory' . S.fromList+    mcA cn cm n' m' = mkCH [(cn (n' ^. _Natural), ixa), (cm (m' ^. _Natural), ixb)]+    mcB c x i = mkCH [(c (x ^. _Natural), i)]++  -- * [R n, R m]   = [R (n + m)]+  compressHistory (mcA R R n m) === mcB R (n + m) ixb++  -- * [L n, R m]   = [L (n + m)]+  compressHistory (mcA L L n m) === mcB L (n + m) ixb++  let+    rlch = compressHistory (mcA R L n m)+    lrch = compressHistory (mcA L R n m)+  when (n > m) $ do+    -- * [R n, L m]   = [R (n - m)] where n > m+    rlch === mcB R (n - m) ixa+    -- * [L n, R m]   = [L (n - m)] where n > m+    lrch === mcB L (n - m) ixa++  when (n < m) $ do+    -- * [R n, L m]   = [L (m - n)] where n < m+    rlch === mcB L (m - n) ixb+    -- * [L n, R m]   = [R (m - n)] where n < m+    lrch === mcB R (m - n) ixb++  -- * [DAt k, R n] = [DAt k]+  compressHistory (mkCH [(DAt "KeyName", ixa), (R (n ^. _Natural), ixb)]) === mkCH [(DAt "KeyName", ixa)]+ prop_uncons_consCommaSep :: Property prop_uncons_consCommaSep = property $ do   cs <- forAll $ CS.genCommaSeparated WS.genWS Gen.bool@@ -177,7 +221,7 @@       -- $ D.atKey "beep" (D.maybeOrNull D.bool)  tripping_properties :: TestTree-tripping_properties = testGroup "Round Trip"+tripping_properties = testGroup "Properties"   [ testProperty "CommaSeparated: cons . uncons = id"                  prop_uncons_consCommaSep   , testProperty "CommaSeparated (disregard WS): cons . uncons = id"   prop_uncons_consCommaSepVal   , testProperty "Char -> JChar Digit -> Maybe Char = Just id"         prop_jchar@@ -188,6 +232,7 @@   , testProperty "Maybe Bool (generic)"                                prop_tripping_maybe_bool_generic   , testProperty "Image record (generic)"                              prop_tripping_image_record_generic   , testProperty "Newtype with Options (generic)"                      prop_tripping_newtype_fudge_generic+  , testProperty "Condensing History"                                  prop_history_condense   ]  parser_properties :: TestTree

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.4.1.0+version:             0.4.2.0  -- A short (one-line) description of the package. synopsis:            JSON wrangling