diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ # Revision history for waargonaut +## 0.5.1.0 -- 2019-01-02 + +* Fix order of `either` decoder to match documentation, `Right` decoder was not being attempted first. +* Expose functionality to check the 'type' of the JSON at the current cursor position. +* Update list decoder to check that we're at an array before attempting to decode. It will now fail when attempting to decode a list and something of type list is not found. Previously it would return an empty list when a number was present. + ## 0.5.0.0 -- 2018-12-18 * Changed internal builder from `ByteString` to `Text` builder. diff --git a/src/Waargonaut/Decode.hs b/src/Waargonaut/Decode.hs --- a/src/Waargonaut/Decode.hs +++ b/src/Waargonaut/Decode.hs @@ -20,6 +20,7 @@ , JCurs (..) , ParseFn , Err (..) + , JsonType (..) -- * Runners , runDecode @@ -58,6 +59,10 @@ , fromKeyOptional , atKeyOptional + -- * Inspection + , withType + , jsonTypeAt + -- * Provided Decoders , leftwardCons , rightwardSnoc @@ -81,6 +86,8 @@ , nonempty , listAt , list + , objectAsKeyValuesAt + , objectAsKeyValues , withDefault , maybeOrNull , either @@ -97,6 +104,7 @@ traverseOf, view, ( # ), (.~), (^.), _Left, _Wrapped) +import Control.Monad.Error.Lens (throwing) import Prelude (Bool, Bounded, Char, Eq, Int, Integral, @@ -111,8 +119,7 @@ import Control.Monad.Morph (embed, generalize) import Control.Monad.Except (catchError, lift, - liftEither, - throwError) + liftEither) import Control.Monad.Reader (ReaderT (..), ask, local, runReaderT) import Control.Monad.State (MonadState) @@ -120,6 +127,7 @@ import Control.Error.Util (note) import Control.Monad.Error.Hoist ((), ()) +import Data.Bool (Bool (..)) import Data.Either (Either (..)) import qualified Data.Either as Either (either) import Data.Foldable (Foldable, foldl, @@ -171,8 +179,11 @@ import Waargonaut.Decode.Types (CursorHistory, DecodeResult (..), Decoder (..), - JCurs (..), ParseFn, - SuccinctCursor) + JCurs (..), + JsonType (..), + ParseFn, + SuccinctCursor, + jsonTypeAt) -- | Function to define a 'Decoder' for a specific data type. -- @@ -268,8 +279,17 @@ -- @ [*1,2,3] @ -- -- This function is essential when dealing with the inner elements of objects or --- arrays. As you must first move 'down' into the focus. +-- arrays. As you must first move 'down' into the focus. However, you cannot +-- move down into an empty list or empty object. The reason for this is that +-- there will be nothing in the index for the element at the first position. +-- Thus the movement will be considered invalid. -- +-- These will fail if you attempt to move 'down': +-- +-- @ *[] @ +-- +-- @ *{} @ +-- down :: Monad f => JCurs @@ -308,7 +328,7 @@ moveToRankN newRank c = if JC.balancedParens (c ^. _Wrapped) .?. Pos.lastPositionOf newRank then pure $ c & _Wrapped . cursorRankL .~ newRank - else throwError $ InputOutOfBounds newRank + else throwing _InputOutOfBounds newRank -- | Move the cursor rightwards 'n' times. -- @@ -384,7 +404,7 @@ if JC.balancedParens c .?. Pos.lastPositionOf rnk then liftEither (p cursorTxt) - else throwError (InputOutOfBounds rnk) + else throwing _InputOutOfBounds rnk -- Internal function to record the current rank of the cursor into the zipper history recordRank @@ -506,7 +526,7 @@ fromKeyOptional k d c = focus' =<< catchError (pure <$> moveToKey k c) (\de -> case de of KeyNotFound _ -> pure Nothing - _ -> throwError de) + _ -> throwing _DecodeError de) where focus' = maybe (pure Nothing) (fmap Just . focus d) @@ -543,6 +563,28 @@ jsonAtCursor p curs >>= liftEither . note (ConversionFailure m) . c +-- | Attempt to work with a 'JCurs' provided the type of 'Json' at the current +-- position matches your expectations. +-- +-- Such as: +-- +-- @ +-- withType JsonTypeArray d +-- @ +-- +-- 'd' will only be entered if the cursor at the current position is a JSON +-- array: '[]'. +-- +withType + :: Monad f + => JsonType + -> (JCurs -> DecodeResult f a) + -> JCurs + -> DecodeResult f a +withType t d c = + if maybe False (== t) $ jsonTypeAt (unJCurs c) then d c + else throwing _TypeMismatch t + -- | Higher order function for combining a folding function with repeated cursor -- movements. This lets you combine arbitrary cursor movements with an accumulating -- function. @@ -586,14 +628,14 @@ -- | C -- -- decodeMyEnum :: Monad f => Decoder f MyEnum --- decodeMyEnum = D.oneOf D.text "MyEnum" +-- decodeMyEnum = D.oneOf D.text \"MyEnum\" -- [ ("a", A) -- , ("b", B) -- , ("c", C) -- ] -- -- decodeMyEnumFromInt :: Monad f => Decoder f MyEnum --- decodeMyEnumFromInt = D.oneOf D.int "MyEnum" +-- decodeMyEnumFromInt = D.oneOf D.int \"MyEnum\" -- [ (1, A) -- , (2, B) -- , (3, C) @@ -613,7 +655,7 @@ foldr (\i x -> g i x) err where g (a,b) = d >>= \t -> if t == a then pure b else err - err = throwError (ConversionFailure l) + err = throwing _ConversionFailure l -- | From the current cursor position, move leftwards one position at a time and -- push each 'a' onto the front of some 'Cons' structure. @@ -779,7 +821,7 @@ -> Decoder f a -> Decoder f b prismDOrFail' e p d = withCursor $ - focus d >=> Either.either (throwError . e) pure . matching p + focus d >=> Either.either (throwing _DecodeError . e) pure . matching p -- | Decode an 'Int'. int :: Monad f => Decoder f Int @@ -833,7 +875,7 @@ => Decoder f a -> JCurs -> DecodeResult f (NonEmpty a) -nonemptyAt elemD = down >=> \curs -> do +nonemptyAt elemD = withType JsonTypeArray $ down >=> \curs -> do h <- focus elemD curs DI.try (moveRight1 curs) >>= maybe (pure $ h :| []) @@ -850,14 +892,34 @@ => Decoder f a -> JCurs -> DecodeResult f [a] -listAt elemD curs = DI.try (down curs) >>= maybe - (pure mempty) - (rightwardSnoc mempty elemD) +listAt elemD = withType JsonTypeArray $ \c -> + DI.try (down c) >>= maybe (pure mempty) (rightwardSnoc mempty elemD) -- | Helper function to simplify writing a '[]' decoder. list :: Monad f => Decoder f a -> Decoder f [a] list d = withCursor (listAt d) +-- | Try to decode an object using the given key and value 'Decoder's at the +-- given cursor. +objectAsKeyValuesAt + :: Monad f + => Decoder f k + -> Decoder f v + -> JCurs + -> DecodeResult f [(k,v)] +objectAsKeyValuesAt keyD valueD = withType JsonTypeObject $ \curs -> + DI.try (down curs) >>= maybe + (pure mempty) + (foldCursor snoc (moveRight1 >=> moveRight1) mempty (withCursor $ \c -> do + k <- focus keyD c + v <- moveRight1 c >>= focus valueD + pure (k,v) + )) + +-- | Helper function to simplify writing a '{}' decoder. +objectAsKeyValues :: Monad f => Decoder f k -> Decoder f v -> Decoder f [(k,v)] +objectAsKeyValues k v = withCursor (objectAsKeyValuesAt k v) + -- | Try to decode an optional value, returning the given default value if -- 'Nothing' is returned. withDefault @@ -875,7 +937,7 @@ => Decoder f a -> Decoder f (Maybe a) maybeOrNull a = - (Nothing <$ null) (Just <$> a) + (Just <$> a) (Nothing <$ null) -- | Decode either an 'a' or a 'b', failing if neither 'Decoder' succeeds. The -- 'Right' decoder is attempted first. @@ -885,4 +947,4 @@ -> Decoder f b -> Decoder f (Either a b) either leftD rightD = - (Left <$> leftD) (Right <$> rightD) + (Right <$> rightD) (Left <$> leftD) diff --git a/src/Waargonaut/Decode/Error.hs b/src/Waargonaut/Decode/Error.hs --- a/src/Waargonaut/Decode/Error.hs +++ b/src/Waargonaut/Decode/Error.hs @@ -11,6 +11,8 @@ import GHC.Word (Word64) +import HaskellWorks.Data.Json.Type (JsonType) + import Data.Text (Text) import Waargonaut.Decode.ZipperMove (ZipperMove) @@ -29,6 +31,7 @@ -- data DecodeError = ConversionFailure Text + | TypeMismatch JsonType | KeyDecodeFailed | KeyNotFound Text | FailedToMove ZipperMove @@ -41,6 +44,7 @@ class AsDecodeError r where _DecodeError :: Prism' r DecodeError _ConversionFailure :: Prism' r Text + _TypeMismatch :: Prism' r JsonType _KeyDecodeFailed :: Prism' r () _KeyNotFound :: Prism' r Text _FailedToMove :: Prism' r ZipperMove @@ -49,6 +53,7 @@ _ParseFailed :: Prism' r Text _ConversionFailure = _DecodeError . _ConversionFailure + _TypeMismatch = _DecodeError . _TypeMismatch _KeyDecodeFailed = _DecodeError . _KeyDecodeFailed _KeyNotFound = _DecodeError . _KeyNotFound _FailedToMove = _DecodeError . _FailedToMove @@ -64,6 +69,13 @@ (\x -> case x of ConversionFailure y -> Right y _ -> Left x + ) + + _TypeMismatch + = L.prism TypeMismatch + (\x -> case x of + TypeMismatch y -> Right y + _ -> Left x ) _KeyDecodeFailed diff --git a/src/Waargonaut/Decode/Types.hs b/src/Waargonaut/Decode/Types.hs --- a/src/Waargonaut/Decode/Types.hs +++ b/src/Waargonaut/Decode/Types.hs @@ -14,6 +14,8 @@ , Decoder (..) , DecodeResult (..) , JCurs (..) + , jsonTypeAt + , JsonType(..) ) where import Control.Lens (Rewrapped, Wrapped (..), @@ -36,6 +38,7 @@ import HaskellWorks.Data.BalancedParens (SimpleBalancedParens) import HaskellWorks.Data.Json.Cursor (JsonCursor (..)) +import HaskellWorks.Data.Json.Type (JsonType (..), JsonTypeAt (..)) import HaskellWorks.Data.Positioning (Count) import HaskellWorks.Data.RankSelect.Poppy512 (Poppy512) @@ -95,7 +98,7 @@ -- | Wrapper type for the 'SuccinctCursor' newtype JCurs = JCurs { unJCurs :: SuccinctCursor - } + } deriving JsonTypeAt instance JCurs ~ t => Rewrapped JCurs t diff --git a/test/Decoder.hs b/test/Decoder.hs --- a/test/Decoder.hs +++ b/test/Decoder.hs @@ -20,7 +20,6 @@ import qualified Data.ByteString as BS 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 @@ -53,7 +52,9 @@ , testCase "Using Alt (Error) - Records BranchFail" decodeAltError , testCase "List Decoder" listDecoder , testCase "NonEmpty List Decoder" nonEmptyDecoder + , testCase "Object Decoder" objectAsKeyValuesDecoder , testCase "Absent Key Decoder" absentKeyDecoder + , testCase "Either decoding order - Right first" decodeEitherRightFirst ] nonEmptyDecoder :: Assertion @@ -64,11 +65,18 @@ ok = "[1]" notOkay = "[]" + badTypeObj = "{}" + badTypeText = "\"test\"" + badTypeNum = "3" + badElem = "[1, \"fred\"]" assertBool "NonEmpty Decoder - fail! non-empty list decoder BROKEN. Start panicking" (Either.isRight (dec ok)) assertBool "NonEmpty Decoder - empty list shouldn't succeed" (Either.isLeft (dec notOkay)) assertBool "NonEmpty Decoder - invalid element decoder accepted" (Either.isLeft (dec badElem)) + assertBool "NonEmpty Decoder - invalid type accepted - object" (Either.isLeft (dec badTypeObj)) + assertBool "NonEmpty Decoder - invalid type accepted - text" (Either.isLeft (dec badTypeText)) + assertBool "NonEmpty Decoder - invalid type accepted - num" (Either.isLeft (dec badTypeNum)) listDecoder :: Assertion listDecoder = do @@ -78,14 +86,40 @@ ok = "[1,2,3]" okE = "[]" - badShape = "{}" + badTypeObj = "{}" + badTypeText = "\"test\"" + badTypeNum = "3" badElem = "[\"fred\", \"susan\"]" assertBool "List Decoder - fail! List Decoder BROKEN. Start panicking." (Either.isRight (dec ok)) assertBool "List Decoder - empty list fail" (Either.isRight (dec okE)) - assertBool "List Decoder - move down should return empty list" (Either.isRight (dec badShape)) + assertBool "List Decoder - invalid type accepted - object" (Either.isLeft (dec badTypeObj)) + assertBool "List Decoder - invalid type accepted - text" (Either.isLeft (dec badTypeText)) + assertBool "List Decoder - invalid type accepted - num" (Either.isLeft (dec badTypeNum)) assertBool "List Decoder - invalid element decoder accepted" (Either.isLeft (dec badElem)) +objectAsKeyValuesDecoder :: Assertion +objectAsKeyValuesDecoder = do + let + dec = D.runPureDecode (D.objectAsKeyValues D.text D.int) parseBS . D.mkCursor + + ok = "{\"1\":1,\"2\":2,\"3\":3}" + okE = "{}" + + badTypeArray = "[]" + badTypeText = "\"test\"" + badTypeNum = "3" + badKey = "{1:1}" + badValue = "{\"1\":\"fred\", \"2\":\"susan\"}" + + assertBool "Object Decoder - fail! Object Decoder BROKEN. Start panicking." (Either.isRight (dec ok)) + assertBool "Object Decoder - empty list fail" (Either.isRight (dec okE)) + assertBool "Object Decoder - invalid type accepted - object" (Either.isLeft (dec badTypeArray)) + assertBool "Object Decoder - invalid type accepted - text" (Either.isLeft (dec badTypeText)) + assertBool "Object Decoder - invalid type accepted - num" (Either.isLeft (dec badTypeNum)) + assertBool "Object Decoder - invalid key decoder accepted" (Either.isLeft (dec badKey)) + assertBool "Object Decoder - invalid value decoder accepted" (Either.isLeft (dec badValue)) + decodeTestMissingObjKey :: Assertion decodeTestMissingObjKey = do let @@ -170,7 +204,14 @@ (const (assertFailure "Should not succeed")) decodeEitherAlt :: Monad f => D.Decoder f (Either.Either Text Int) -decodeEitherAlt = (Either.Left <$> D.text) (Either.Right <$> D.int) +decodeEitherAlt = D.either D.text D.int + +decodeEitherRightFirst :: Assertion +decodeEitherRightFirst = do + let d = D.runPureDecode (D.either D.scientific D.int) parseBS . D.mkCursor + + d "44e333" @?= Either.Right (Either.Left 44e333) + d "33" @?= Either.Right (Either.Right 33) decodeAlt :: Assertion decodeAlt = do diff --git a/waargonaut.cabal b/waargonaut.cabal --- a/waargonaut.cabal +++ b/waargonaut.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.5.0.0 +version: 0.5.1.0 -- A short (one-line) description of the package. synopsis: JSON wrangling