diff --git a/src/Waargonaut/Decode.hs b/src/Waargonaut/Decode.hs --- a/src/Waargonaut/Decode.hs +++ b/src/Waargonaut/Decode.hs @@ -91,91 +91,100 @@ ) where -import GHC.Word (Word64) +import GHC.Word (Word64) -import Control.Lens (Cons, Lens', Prism', - Snoc, cons, lens, - matching, modifying, - preview, snoc, - traverseOf, view, - ( # ), (.~), (^.), - _Wrapped) -import Control.Monad.Error.Lens (throwing) +import Control.Lens (Cons, Lens', + Prism', Snoc, + cons, lens, + matching, + modifying, + preview, snoc, + traverseOf, + view, ( # ), + (.~), (^.), + _Wrapped) +import Control.Monad.Error.Lens (throwing) -import Prelude (Bool, Bounded, Char, - Eq, Int, Integral, - String, - fromIntegral, (-), - (==)) +import Prelude (Bool, Bounded, + Char, Eq, Int, + Integral, + String, (-), + (==), fromIntegral) -import Control.Applicative (Applicative (..)) -import Control.Category ((.)) -import Control.Monad (Monad (..), (=<<), - (>=>)) -import Control.Monad.Morph (embed, generalize) +import Control.Applicative (Applicative (..)) +import Control.Category ((.)) +import Control.Monad (Monad (..), + (=<<), (>=>)) +import Control.Monad.Morph (embed, + generalize) -import Control.Monad.Except (catchError, lift, - liftEither) -import Control.Monad.Reader (ReaderT (..), ask, - runReaderT) -import Control.Monad.State (MonadState) +import Control.Monad.Except (catchError, + lift, + liftEither) +import Control.Monad.Reader (ReaderT (..), + ask, + runReaderT) +import Control.Monad.State (MonadState) -import Control.Error.Util (note) -import Control.Monad.Error.Hoist ((), ()) +import Control.Error.Util (note) +import Control.Monad.Error.Hoist ((), ()) -import Data.Either (Either (..)) -import qualified Data.Either as Either (either) -import Data.Foldable (Foldable, elem, - foldl, foldr) -import Data.Function (const, flip, ($), - (&)) -import Data.Functor (fmap, (<$), (<$>)) -import Data.Functor.Alt (()) -import Data.Functor.Identity (Identity) -import Data.Monoid (mempty) -import Data.Scientific (Scientific) +import Data.Either (Either (..)) +import qualified Data.Either as Either (either) +import Data.Foldable (Foldable, elem, + foldl, foldr) +import Data.Function (const, flip, + ($), (&)) +import Data.Functor (fmap, (<$), + (<$>)) +import Data.Functor.Alt (()) +import Data.Functor.Identity (Identity) +import Data.Monoid (mempty) +import Data.Scientific (Scientific) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Maybe (Maybe (..), - fromMaybe, maybe) -import Natural (Natural, replicate, - successor', zero') +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (Maybe (..), + fromMaybe, + maybe) +import Natural (Natural, + replicate, + successor', + zero') -import Data.Text (Text) +import Data.Text (Text) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL -import HaskellWorks.Data.Positioning (Count) -import qualified HaskellWorks.Data.Positioning as Pos +import HaskellWorks.Data.Positioning (Count) +import qualified HaskellWorks.Data.Positioning as Pos -import qualified HaskellWorks.Data.BalancedParens.FindOpen as BP +import qualified HaskellWorks.Data.BalancedParens.FindOpen as BP -import HaskellWorks.Data.Bits ((.?.)) -import HaskellWorks.Data.TreeCursor (TreeCursor (..)) +import HaskellWorks.Data.Bits ((.?.)) +import HaskellWorks.Data.TreeCursor (TreeCursor (..)) -import HaskellWorks.Data.Json.Cursor (JsonCursor (..)) -import qualified HaskellWorks.Data.Json.Cursor as JC +import HaskellWorks.Data.Json.Backend.Standard.Cursor (JsonCursor (..)) +import qualified HaskellWorks.Data.Json.Backend.Standard.Cursor as JC -import Waargonaut.Decode.Error (AsDecodeError (..), - DecodeError (..), - Err (..)) -import Waargonaut.Decode.ZipperMove (ZipperMove (..)) -import Waargonaut.Types (Json) +import Waargonaut.Decode.Error (AsDecodeError (..), + DecodeError (..), + Err (..)) +import Waargonaut.Decode.ZipperMove (ZipperMove (..)) +import Waargonaut.Types (Json) -import qualified Waargonaut.Decode.Internal as DI +import qualified Waargonaut.Decode.Internal as DI import Waargonaut.Decode.Runners -import Waargonaut.Decode.Types (CursorHistory, - DecodeResult (..), - Decoder (..), - JCurs (..), - JsonType (..), - SuccinctCursor, - jsonTypeAt, - mkCursor) +import Waargonaut.Decode.Types (CursorHistory, DecodeResult (..), + Decoder (..), + JCurs (..), + JsonType (..), + SuccinctCursor, + jsonTypeAt, + mkCursor) -- | Function to define a 'Decoder' for a specific data type. -- @@ -383,14 +392,14 @@ -> DecodeResult f a jsonAtCursor p jc = do let - c = jc ^. _Wrapped - rnk = c ^. cursorRankL + c = jc ^. _Wrapped + rnk = c ^. cursorRankL - leading = fromIntegral $ Pos.toCount (JC.jsonCursorPos c) - cursorTxt = BS8.drop leading (JC.cursorText c) + leading = Pos.toCount $ JC.jsonCursorPos c + txt = BS.drop (fromIntegral leading) $ JC.cursorText c if JC.balancedParens c .?. Pos.lastPositionOf rnk - then liftEither (p cursorTxt) + then liftEither (p txt) else throwing _InputOutOfBounds rnk -- Internal function to record the current rank of the cursor into the zipper history @@ -608,17 +617,17 @@ -- An example of such an input is: -- -- @ --- { "Collection" : { --- "BobsInput_ce43dff22": { --- "someValue": "Some data" +-- { \"Collection\" : { +-- \"BobsInput_ce43dff22\": { +-- \"someValue\": \"Some data\" -- }, --- "FredsInput_a4b32def": { --- "someValue": "Some different data" +-- \"FredsInput_a4b32def\": { +-- \"someValue\": \"Some different data\" -- } -- } -- @ -- --- Where those key values like "XInput_YYYY" are to be included in the object. +-- Where those key values like \"XInput_YYYY\" are to be included in the object. -- -- Given a type like this: -- @@ -628,31 +637,28 @@ -- , _containsItsKey_SomeValue :: Text -- } -- @ --- +-- -- To decode the above you would use this function like so: --- +-- -- @ -- takesKeyDecoder :: Monad f => Text -> Decoder f ContainsItsKey --- takesKeyDecoder k = ContainsItsKey k <$> D.atKey "someValue" D.text +-- takesKeyDecoder k = ContainsItsKey k \<$\> D.atKey \"someValue\" D.text -- -- collectionDecoder :: Monad f => Decoder f [ContainsItsKey] --- collectionDecoder = D.atKey "Collection" $ D.passKeysToValues D.text takesKeyDecoder +-- collectionDecoder = D.atKey \"Collection\" $ D.passKeysToValues [] D.text takesKeyDecoder -- @ -- passKeysToValues :: ( Snoc c c v v , Monad f ) - => c + => c -> Decoder f k -> (k -> Decoder f v) -> Decoder f c passKeysToValues empty dK kDV = withCursor $ down >=> foldCursor snoc (moveRightN (successor' (successor' zero'))) empty - (withCursor $ \c' -> do - k <- focus dK c' - moveRight1 c' >>= focus (kDV k) - ) + (withCursor $ \c' -> focus dK c' >>= \k -> moveRight1 c' >>= focus (kDV k)) -- | Helper function for "pattern matching" on a decoded value to some Haskell -- value. The 'Text' argument is used in the error message should this decoder 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 @@ -19,39 +19,39 @@ , JsonType(..) ) where -import Control.Lens (Rewrapped, Wrapped (..), - iso) -import Control.Monad.Except (MonadError (..)) -import Control.Monad.Morph (MFunctor (..), - MMonad (..)) -import Control.Monad.Reader (MonadReader, - ReaderT (..)) -import Control.Monad.State (MonadState) -import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Lens (Rewrapped, + Wrapped (..), + iso) +import Control.Monad.Except (MonadError (..)) +import Control.Monad.Morph (MFunctor (..), + MMonad (..)) +import Control.Monad.Reader (MonadReader, + ReaderT (..)) +import Control.Monad.State (MonadState) +import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Functor.Alt (Alt (..)) -import qualified Data.Text as Text +import Data.Functor.Alt (Alt (..)) +import qualified Data.Text as Text -import GHC.Word (Word64) +import GHC.Word (Word64) -import Data.ByteString (ByteString) -import Data.Vector.Storable (Vector) +import Data.ByteString (ByteString) +import Data.Vector.Storable (Vector) -import HaskellWorks.Data.BalancedParens (SimpleBalancedParens) -import HaskellWorks.Data.FromByteString (fromByteString) -import HaskellWorks.Data.Json.Cursor (JsonCursor (..)) -import HaskellWorks.Data.Json.Type (JsonType (..), - JsonTypeAt (..)) -import HaskellWorks.Data.Positioning (Count) -import HaskellWorks.Data.RankSelect.Poppy512 (Poppy512) +import HaskellWorks.Data.BalancedParens (SimpleBalancedParens) +import HaskellWorks.Data.Json.Backend.Standard.Cursor (JsonCursor (..)) +import HaskellWorks.Data.Json.Backend.Standard.Fast (makeCursor) +import HaskellWorks.Data.Json.Type (JsonType (..), + JsonTypeAt (..)) +import HaskellWorks.Data.Positioning (Count) +import HaskellWorks.Data.RankSelect.Poppy512 (Poppy512) -import Waargonaut.Decode.Internal (CursorHistory', - DecodeError (..), - DecodeResultT (..), - ZipperMove (BranchFail), - recordZipperMove) +import Waargonaut.Decode.Internal (CursorHistory', DecodeError (..), + DecodeResultT (..), + ZipperMove (BranchFail), + recordZipperMove) -import Waargonaut.Types (Json) +import Waargonaut.Types (Json) -- | We define the index of our 'CursorHistory'' to be the 'HaskellWorks.Data.Positioning.Count'. type CursorHistory = @@ -112,7 +112,7 @@ -- | Take a 'ByteString' input and build an index of the JSON structure inside -- mkCursor :: ByteString -> JCurs -mkCursor = JCurs . fromByteString +mkCursor = JCurs . makeCursor -- | Provide some of the type parameters that the underlying 'DecodeResultT' -- requires. This contains the state and error management as we walk around our diff --git a/src/Waargonaut/Encode.hs b/src/Waargonaut/Encode.hs --- a/src/Waargonaut/Encode.hs +++ b/src/Waargonaut/Encode.hs @@ -57,6 +57,7 @@ -- * Object encoder helpers , mapLikeObj , atKey + , atOptKey , intAt , textAt , boolAt @@ -86,6 +87,7 @@ , nonempty' , list' , atKey' + , atOptKey' , mapLikeObj' , mapToObj' , keyValuesAsObj' @@ -267,7 +269,7 @@ -- | Transform the given input using the 'Encoder' to its 'Json' data structure representation. asJson :: Applicative f => Encoder f a -> a -> f Json -asJson e = runEncoder e +asJson = runEncoder {-# INLINE asJson #-} -- | As per 'asJson', but with the 'Encoder' specialised to 'Identity' @@ -506,6 +508,19 @@ atKey k enc v t = (\v' -> t & at k ?~ v') <$> runEncoder enc v +atOptKey + :: ( At t + , IxValue t ~ Json + , Applicative f + ) + => Index t + -> Encoder f a + -> Maybe a + -> t + -> f t +atOptKey k enc = + Maybe.maybe pure (atKey k enc) + -- | Encode an 'a' at the given index on the JSON object. atKey' :: ( At t @@ -518,6 +533,33 @@ -> t atKey' k enc v = at k ?~ asJson' enc v +{-# INLINE atKey' #-} + +-- | Optionally encode a @key : value@ pair on an object. +-- +-- @ +-- encoder = E.mapLikeObj \$ \\a -> +-- atKey' "A" E.text (_getterA a) +-- atOptKey' "B" E.int (_maybeB a) +-- +-- simplePureEncodeByteString encoder (Foo "bob" (Just 33)) = "{\"A\":\"bob\",\"B\":33}" +-- +-- simplePureEncodeByteString encoder (Foo "bob" Nothing) = "{\"A\":\"bob\"}" +-- +-- @ +-- +atOptKey' + :: ( At t + , IxValue t ~ Json + ) + => Index t + -> Encoder' a + -> Maybe a + -> t + -> t +atOptKey' k enc = + Maybe.maybe id (atKey' k enc) +{-# INLINE atOptKey' #-} -- | Encode an 'Int' at the given 'Text' key. intAt diff --git a/src/Waargonaut/Generic.hs b/src/Waargonaut/Generic.hs --- a/src/Waargonaut/Generic.hs +++ b/src/Waargonaut/Generic.hs @@ -357,6 +357,7 @@ instance JsonEncode t Int where mkEncoder = Tagged E.int instance JsonEncode t Scientific where mkEncoder = Tagged E.scientific instance JsonEncode t Bool where mkEncoder = Tagged E.bool +instance JsonEncode t Json where mkEncoder = Tagged E.json -- | -- Decoding Typeclass for Waargonaut @@ -392,6 +393,7 @@ instance JsonDecode t Int where mkDecoder = Tagged D.int instance JsonDecode t Scientific where mkDecoder = Tagged D.scientific instance JsonDecode t Bool where mkDecoder = Tagged D.bool +instance JsonDecode t Json where mkDecoder = Tagged D.json type JTag = String diff --git a/src/Waargonaut/Prettier.hs b/src/Waargonaut/Prettier.hs --- a/src/Waargonaut/Prettier.hs +++ b/src/Waargonaut/Prettier.hs @@ -11,6 +11,9 @@ -- * Functions , prettyJson , simpleEncodePretty + + -- * Rexports + , module Natural ) where import Prelude (Eq, Show, (+), (-)) @@ -77,6 +80,12 @@ -- | Encode an @a@ directly to a 'ByteString' using the provided 'Encoder', the -- output will have newlines and indentation added based on the 'InlineOption' and -- 'NumSpaces'. +-- +-- @ +-- let two = successor' $ successor' zero' +-- simpleEncodePretty ArrayOnly (IndentStep two) (NumSpaces two) myEncoder myVal +-- @ +-- simpleEncodePretty :: Applicative f => InlineOption @@ -132,7 +141,8 @@ -- increasing that indentation by two spaces for each nested object or array. -- -- @ --- prettyJson ArrayOnly 2 2 j +-- let two = successor' $ successor' zero' +-- prettyJson ArrayOnly (IndentStep two) (NumSpaces two) j -- @ -- prettyJson :: InlineOption -> IndentStep -> NumSpaces -> Json -> Json diff --git a/test/Encoder.hs b/test/Encoder.hs --- a/test/Encoder.hs +++ b/test/Encoder.hs @@ -10,7 +10,7 @@ import Control.Lens ((<&>), (?~)) import Test.Tasty (TestName, TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, testCase, (@?=)) import Data.Proxy (Proxy (..)) @@ -25,6 +25,22 @@ import Waargonaut.Generic (GWaarg, mkEncoder, proxy) import Waargonaut.Types.Json (oat) +testOptionalKeyValue :: Assertion +testOptionalKeyValue = do + let + encoder = E.mapLikeObj $ \(a,b) -> + E.atKey' "A" E.text a . + E.atOptKey' "B" E.int b + + hasKey = ("bob", Just 33) + withKey = "{\"A\":\"bob\",\"B\":33}" + + noKey = ("bob", Nothing) + withoutKey = "{\"A\":\"bob\"}" + + E.simplePureEncodeTextNoSpaces encoder hasKey @?= withKey + E.simplePureEncodeTextNoSpaces encoder noKey @?= withoutKey + testImageEncodedNoSpaces :: Text testImageEncodedNoSpaces = "{\"Width\":800,\"Height\":600,\"Title\":\"View from 15th Floor\",\"Animated\":false,\"IDs\":[116,943,234,38793]}" @@ -67,6 +83,7 @@ , tCase "Image (Generic)" enc testImageDataType testImageEncodedNoSpaces , tCase "newtype - with constructor name" enc testFudge testFudgeEncodedWithConsName , tCase "Overlayed" encodeOverlay testOverlayed testOverlayedOut + , testCase "Optional Key:Value" testOptionalKeyValue ] where enc = proxy mkEncoder (Proxy :: Proxy GWaarg) 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.6.1.0 +version: 0.6.2.0 -- A short (one-line) description of the package. synopsis: JSON wrangling @@ -75,7 +75,7 @@ tested-with: GHC==8.0.2 , GHC==8.2.2 , GHC==8.4.4 - , GHC==8.6.2 + , GHC==8.6.4 custom-setup setup-depends: base >= 4.9 && <5 @@ -150,7 +150,7 @@ , bytestring >= 0.10.6 && < 0.11 , parsers >= 0.12 && < 0.13 , digit >= 0.7 && < 0.8 - , semigroups >= 0.8.4 && < 0.19 + , semigroups >= 0.8.4 && < 0.20 , scientific >= 0.3 && < 0.4 , distributive >= 0.5 && < 0.7 , nats >= 1 && <1.2 @@ -166,11 +166,13 @@ , bifunctors >= 5 && < 5.6 , contravariant >= 1.4 && < 1.6 , wl-pprint-annotated >= 0.1 && < 0.2 - , hw-json >= 0.9.0.1 && < 0.10 + + , hw-json >= 1.0.0.2 && < 1.2 , hw-prim >= 0.6 && < 0.7 , hw-balancedparens >= 0.2 && < 0.3 - , hw-rankselect >= 0.10 && < 0.13 + , hw-rankselect >= 0.13 && < 0.14 , hw-bits >= 0.7 && < 0.8 + , tagged >= 0.8.5 && < 0.9 , semigroupoids >= 5.2.2 && < 5.4 , natural >= 0.3 && < 0.4 @@ -238,7 +240,7 @@ , bytestring >= 0.10.6 && < 0.11 , digit >= 0.7 && < 0.8 , text >= 1.2 && < 1.3 - , semigroups >= 0.8.4 && < 0.19 + , semigroups >= 0.8.4 && < 0.20 , zippers >= 0.2 && < 0.3 , vector >= 0.12 && < 0.13 , generics-sop >= 0.4 && < 0.5 @@ -253,6 +255,12 @@ , filepath >= 1.4 && < 1.5 , tasty-golden >= 2.3 && < 2.4 , unordered-containers >= 0.2.9 && < 0.3 + + , hw-balancedparens >= 0.2 && < 0.3 + , hw-rankselect >= 0.13 && < 0.14 + , hw-bits >= 0.7 && < 0.8 + , hw-json >= 1.0.0.2 && < 1.2 + , hw-prim >= 0.6 && < 0.7 , waargonaut