waargonaut 0.3.0.0 → 0.4.0.0

raw patch · 16 files changed

+843/−355 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +13/−0
• src/Waargonaut/Decode.hs +11/−10
• src/Waargonaut/Decode/Internal.hs +5/−4
• src/Waargonaut/Encode.hs +122/−74
• src/Waargonaut/Encode/Types.hs +129/−0
• src/Waargonaut/Types/CommaSep.hs +6/−8
• src/Waargonaut/Types/JArray.hs +8/−2
• src/Waargonaut/Types/JObject.hs +18/−7
• src/Waargonaut/Types/Json.hs +52/−6
• test/Decoder.hs +40/−8
• test/Decoder/Laws.hs +27/−180
• test/Encoder.hs +30/−14
• test/Encoder/Laws.hs +19/−41
• test/Laws.hs +351/−0
• test/Types/Common.hs +8/−0
• waargonaut.cabal +4/−1

@@ -1,5 +1,18 @@ # Revision history for waargonaut +## 0.4.0.0  -- 2018-11-19++* Redesign & rebuild of `Encoder` internals to allow for greater control and flexibility+* Factor our law tests into their own module (a recheck of these tests is needed)+* Fixed bug in `list` and `nonempty` decoders+* Fixed bug in `foldCursor` function+* Fixed bug in `Cons` instance for `CommaSep`+* Fixed bug in documentation for `atKey`+* Added `_MapLikeObj` `Prism`+* Added some optics into object / maplikeobj keys+* Fixed bug in `maybeOrNull` decoder to be more strict in what it accepts+* Rewrote `either` decoder in terms of the alternative instance to allow for better errors+ ## 0.3.0.0  -- 2018-11-14  * Change to use the `natural` package for `Natural` numbers.

@@ -114,6 +114,7 @@ import           Data.Function                             (const, flip, ($),                                                             (&)) import           Data.Functor                              (fmap, (<$), (<$>))+import           Data.Functor.Alt                          ((<!>)) import           Data.Functor.Identity                     (Identity,                                                             runIdentity) import           Data.Monoid                               (mempty)@@ -123,7 +124,8 @@ import           Data.List.NonEmpty                        (NonEmpty ((:|))) import           Data.Maybe                                (Maybe (..),                                                             fromMaybe, maybe)-import           Natural                                   (Natural, replicate, zero', successor')+import           Natural                                   (Natural, replicate,+                                                            successor', zero')  import           Data.Text                                 (Text) @@ -466,8 +468,8 @@ -- -- myRecDecoder :: Decoder f MyRec -- myRecDecoder = MyRec---   <$> atKey "field_a" text---   <*> atKey "field_b" int+--   \<$> atKey "field_a" text+--   \<*> atKey "field_b" int -- @ -- atKey@@ -705,8 +707,9 @@   -> DecodeResult f (NonEmpty a) nonemptyAt elemD = down >=> \curs -> do   h <- focus elemD curs-  xs <- moveRight1 curs-  (h :|) <$> rightwardSnoc [] elemD xs+  DI.try (moveRight1 curs) >>= maybe+    (pure $ h :| [])+    (fmap (h :|) . rightwardSnoc [] elemD)  -- | Helper to create a 'NonEmpty a' 'Decoder'. nonempty :: Monad f => Decoder f a -> Decoder f (NonEmpty a)@@ -735,7 +738,7 @@   -> Decoder f (Maybe a)   -> Decoder f a withDefault def hasD =-  withCursor (fmap (fromMaybe def) . focus hasD)+  fromMaybe def <$> hasD  -- | Named to match it's 'Encoder' counterpart, this function will decode an -- optional value.@@ -744,7 +747,7 @@   => Decoder f a   -> Decoder f (Maybe a) maybeOrNull a =-  withCursor (DI.try . focus a)+  (Nothing <$ null) <!> (Just <$> a)  -- | Decode either an 'a' or a 'b', failing if neither 'Decoder' succeeds. The -- 'Right' decoder is attempted first.@@ -754,6 +757,4 @@   -> Decoder f b   -> Decoder f (Either a b) either leftD rightD =-  withCursor $ \c ->-    DI.try (focus (Right <$> rightD) c) >>=-    maybe (focus (Left <$> leftD) c) pure+  (Left <$> leftD) <!> (Right <$> rightD)

@@ -329,10 +329,11 @@   go empty   where     go acc cur = do-      me <- fmap (scons acc) <$> try (runDecoder' elemD cur)-      maybe (pure acc)-        (\r -> try (mvCurs cur) >>= maybe (pure r) (go r))-        me+      acc' <- scons acc <$> runDecoder' elemD cur++      try (mvCurs cur) >>= maybe+        (pure acc')+        (go acc')  -- | -- Provide a generalised and low level way of turning a JSON object into a

@@ -10,12 +10,16 @@ module Waargonaut.Encode   (     -- * Encoder type-    Encoder (Encoder)+    Encoder   , Encoder'+  , ObjEncoder+  , ObjEncoder'      -- * Creation   , encodeA   , encodePureA+  , jsonEncoder+  , objEncoder      -- * Runners   , runPureEncoder@@ -53,6 +57,9 @@   , keyValuesAsObj   , onObj   , keyValueTupleFoldable+  , extendObject+  , extendMapLikeObject+  , combineObjects      -- * Encoders specialised to Identity   , int'@@ -72,97 +79,75 @@   , mapToObj'   , keyValuesAsObj'   , json'-  , generaliseEncoder'-+  , generaliseEncoder   ) where  -import           Control.Monad.Morph        (MFunctor (..), generalize)+import           Control.Applicative                  (Applicative (..), (<$>))+import           Control.Category                     (id, (.))+import           Control.Lens                         (AReview, At, Index,+                                                       IxValue, Prism', at,+                                                       cons, review, ( # ),+                                                       (?~), _Empty, _Wrapped)+import qualified Control.Lens                         as L -import           Control.Applicative        (Applicative (..), (<$>))-import           Control.Category           (id, (.))-import           Control.Lens               (AReview, At, Index, IxValue,-                                             Prism', Rewrapped, Wrapped (..),-                                             at, cons, iso, review, ( # ), (?~),-                                             _Empty, _Wrapped)-import qualified Control.Lens               as L+import           Prelude                              (Bool, Int, Integral,+                                                       Monad, fromIntegral, fst) -import           Prelude                    (Bool, Int, Integral, Monad,-                                             fromIntegral)+import           Data.Foldable                        (Foldable, foldr, foldrM)+import           Data.Function                        (const, flip, ($), (&))+import           Data.Functor                         (Functor, fmap)+import           Data.Functor.Contravariant           ((>$<))+import           Data.Functor.Contravariant.Divisible (divide)+import           Data.Functor.Identity                (Identity (..))+import           Data.Traversable                     (Traversable, traverse) -import           Data.Foldable              (Foldable, foldr, foldrM)-import           Data.Function              (const, flip, ($), (&))-import           Data.Functor               (Functor, fmap)-import           Data.Functor.Contravariant (Contravariant (..), (>$<))-import           Data.Functor.Identity      (Identity (..))-import           Data.Traversable           (Traversable, traverse)+import           Data.Either                          (Either)+import qualified Data.Either                          as Either+import           Data.List.NonEmpty                   (NonEmpty)+import           Data.Maybe                           (Maybe)+import qualified Data.Maybe                           as Maybe+import           Data.Scientific                      (Scientific) -import           Data.Either                (Either)-import qualified Data.Either                as Either-import           Data.List.NonEmpty         (NonEmpty)-import           Data.Maybe                 (Maybe)-import qualified Data.Maybe                 as Maybe-import           Data.Scientific            (Scientific)+import           Data.Monoid                          (Monoid, mempty)+import           Data.Semigroup                       (Semigroup) -import           Data.Monoid                (Monoid, mempty)-import           Data.Semigroup             (Semigroup)+import qualified Data.ByteString.Builder              as BB+import           Data.ByteString.Lazy                 (ByteString) -import qualified Data.ByteString.Builder    as BB-import           Data.ByteString.Lazy       (ByteString)+import           Data.Map                             (Map)+import qualified Data.Map                             as Map -import           Data.Map                   (Map)-import qualified Data.Map                   as Map+import           Data.Text                            (Text) -import           Data.Text                  (Text)+import           Waargonaut.Encode.Types              (Encoder, Encoder',+                                                       ObjEncoder, ObjEncoder',+                                                       finaliseEncoding,+                                                       generaliseEncoder,+                                                       initialEncoding,+                                                       jsonEncoder, objEncoder,+                                                       runEncoder,+                                                       runPureEncoder) -import           Waargonaut.Types           (AsJType (..), JAssoc (..), JObject,-                                             Json, MapLikeObj (..), WS,-                                             textToJString, wsRemover,-                                             _JNumberInt, _JNumberScientific)-import           Waargonaut.Types.Json      (waargonautBuilder)+import           Waargonaut.Types                     (AsJType (..),+                                                       JAssoc (..), JObject,+                                                       Json, MapLikeObj (..),+                                                       WS, textToJString,+                                                       toMapLikeObj, wsRemover,+                                                       _JNumberInt,+                                                       _JNumberScientific)+import           Waargonaut.Types.Json                (waargonautBuilder) --- |--- Define an "encoder" as a function from some @a@ to some 'Json' with the--- allowance for some context @f@.----newtype Encoder f a = Encoder-  { runEncoder :: a -> f Json -- ^ Run this 'Encoder' to convert the 'a' to 'Json'-  } -instance (Encoder f a) ~ t => Rewrapped (Encoder f a) t--instance Wrapped (Encoder f a) where-  type Unwrapped (Encoder f a) = a -> f Json-  _Wrapped' = iso runEncoder Encoder--instance Contravariant (Encoder f) where-  contramap f (Encoder g) = Encoder (g . f)--instance MFunctor Encoder where-  hoist nat (Encoder eFn) = Encoder (nat . eFn)---- | Generalise an 'Encoder' a' to 'Encoder f a'-generaliseEncoder' :: Monad f => Encoder' a -> Encoder f a-generaliseEncoder' = Encoder . fmap generalize . runEncoder-{-# INLINE generaliseEncoder' #-}---- |--- As a convenience, this type is a pure Encoder over 'Identity' in place of the @f@.-type Encoder' = Encoder Identity- -- | Create an 'Encoder'' for 'a' by providing a function from 'a -> f Json'. encodeA :: (a -> f Json) -> Encoder f a-encodeA = Encoder+encodeA = jsonEncoder  -- | As 'encodeA' but specialised to 'Identity' when the additional flexibility -- isn't needed. encodePureA :: (a -> Json) -> Encoder' a encodePureA f = encodeA (Identity . f) --- | Run the given 'Encoder' to produce a lazy 'ByteString'.-runPureEncoder :: Encoder' a -> a -> Json-runPureEncoder enc = runIdentity . runEncoder enc- -- | Encode an @a@ directly to a 'ByteString' using the provided 'Encoder'. simpleEncodeNoSpaces   :: Applicative f@@ -174,7 +159,7 @@  -- | As per 'simpleEncodeNoSpaces' but specialised the 'f' to 'Data.Functor.Identity' and remove it. simplePureEncodeNoSpaces-  :: Encoder' a+  :: Encoder Identity a   -> a   -> ByteString simplePureEncodeNoSpaces enc =@@ -230,7 +215,8 @@ -- | Encode a 'Maybe' value, using the provided 'Encoder''s to handle the -- different choices. maybe-  :: Encoder f ()+  :: Functor f+  => Encoder f ()   -> Encoder f a   -> Encoder f (Maybe a) maybe encN = encodeA@@ -247,7 +233,8 @@  -- | Encode an 'Either' value using the given 'Encoder's either-  :: Encoder f a+  :: Functor f+  => Encoder f a   -> Encoder f b   -> Encoder f (Either a b) either eA = encodeA@@ -366,7 +353,7 @@   -> Encoder f a   -> Encoder f (t a) encodeWithInner f g =-  Encoder $ fmap f . traverse (runEncoder g)+  jsonEncoder $ fmap f . traverse (runEncoder g)  -- | As per 'traversable' but with the 'f' specialised to 'Data.Functor.Identity'. traversable'@@ -527,6 +514,67 @@   -> Encoder' i mapLikeObj' f = encodePureA $ \a ->   _JObj # (fromMapLikeObj $ f a (_Empty # ()), mempty)++-- |+-- This function allows you to extend the fields on a JSON object created by a+-- separate encoder.+--+extendObject+  :: Functor f+  => ObjEncoder f a+  -> a+  -> (JObject WS Json -> JObject WS Json)+  -> f Json+extendObject encA a f =+  finaliseEncoding encA . f <$> initialEncoding encA a++-- |+-- This function lets you extend the fields on a JSON object but enforces the+-- uniqueness of the keys by working through the 'MapLikeObj' structure.+--+-- This will keep the first occurence of each unique key in the map. So be sure+-- to check your output.+--+extendMapLikeObject+  :: Functor f+  => ObjEncoder f a+  -> a+  -> (MapLikeObj WS Json -> MapLikeObj WS Json)+  -> f Json+extendMapLikeObject encA a f =+  finaliseEncoding encA . floopObj <$> initialEncoding encA a+  where+    floopObj = fromMapLikeObj . f . fst . toMapLikeObj++-- |+-- Given encoders for things that are represented in JSON as 'objects', and a+-- way to get to the 'b' and 'c' from the 'a'. This function lets you create an+-- encoder for 'a'. The two objects are combined to make one single JSON object.+--+-- Given+--+-- @+-- encodeFoo :: ObjEncoder f Foo+-- encodeBar :: ObjEncoder f Bar+-- -- and some wrapping type:+-- data A = { _foo :: Foo, _bar :: Bar }+-- @+--+-- We can use this function to utilise our already defined 'ObjEncoder'+-- structures to give us an encoder for 'A':+--+-- @+-- combineObjects (\aRecord -> (_foo aRecord, _bar aRecord)) encodeFoo encodeBar :: ObjEncoder f Bar+-- @+--+combineObjects+  :: Applicative f+  => (a -> (b, c))+  -> ObjEncoder f b+  -> ObjEncoder f c+  -> ObjEncoder f a+combineObjects f eB eC =+  divide f eB eC  -- | When encoding a JSON object that may contain duplicate keys, this function -- works the same as the 'atKey' function for 'MapLikeObj'.

@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Types and functions that make up the internal structure of the encoders.+--+module Waargonaut.Encode.Types+  ( -- * Types+    EncoderFns (..)++    -- * Useful aliases+  , Encoder+  , Encoder'+  , ObjEncoder+  , ObjEncoder'++    -- * Runners+  , runEncoder+  , runPureEncoder++    -- * Helpers+  , jsonEncoder+  , objEncoder+  , generaliseEncoder+  ) where++import           Control.Monad                        (Monad)+import           Control.Monad.Morph                  (MFunctor (..),+                                                       generalize)++import           Control.Applicative                  (Applicative, liftA2,+                                                       pure)+import           Control.Category                     (id, (.))+import           Control.Lens                         (( # ))++import           Data.Either                          (either)+import           Data.Function                        (const, ($))+import           Data.Functor                         (Functor)+import           Data.Functor.Contravariant           (Contravariant (..))++import           Data.Functor.Contravariant.Divisible (Decidable (..),+                                                       Divisible (..))+import           Data.Monoid                          (mempty)+import           Data.Semigroup                       ((<>))+import           Data.Void                            (absurd)++import           Data.Functor                         (fmap)+import           Data.Functor.Identity                (Identity (..))++import           Waargonaut.Types                     (JObject, Json, WS, _JObj)+++-- |+-- Define an "encoder" as a function from some @a@ to some 'Json' with the+-- allowance for some context @f@.+--+-- The helper functions 'jsonEncoder' and 'objEncoder' are probably what you+-- want to use.+--+data EncoderFns i f a = EncoderFns+  { finaliseEncoding :: i -> Json -- ^ The @i@ need not be the final 'Json' structure. This function will complete the output from 'initialEncoding' to the final 'Json' output.++  , initialEncoding  :: a -> f i -- ^ Run the initial encoding step of the given input. This lets you encode the @a@ to an intermediate structure before utilising the 'finaliseEncoding' function to complete the process.+  }++instance MFunctor (EncoderFns i) where+  hoist nat (EncoderFns f i) = EncoderFns f (nat . i)++-- | Generalise any 'Encoder' a' to 'Encoder f a'+generaliseEncoder :: Monad f => EncoderFns i Identity a -> EncoderFns i f a+generaliseEncoder (EncoderFns f i) = EncoderFns f (generalize . i)++instance Contravariant (EncoderFns o f) where+  contramap f e = EncoderFns (finaliseEncoding e) (initialEncoding e . f)+  {-# INLINE contramap #-}++instance Applicative f => Divisible (EncoderFns (JObject WS Json) f) where+  conquer = objEncoder (const (pure mempty))+  {-# INLINE conquer #-}++  divide atobc (EncoderFns _ oB) (EncoderFns _ oC) = objEncoder $ \a ->+    let+      (b,c) = atobc a+    in+      liftA2 (<>) (oB b) (oC c)+  {-# INLINE divide #-}++instance Applicative f => Decidable (EncoderFns (JObject WS Json) f) where+  lose f = objEncoder $ \a -> absurd (f a)+  {-# INLINE lose #-}++  choose split (EncoderFns _ oB) (EncoderFns _ oC) = objEncoder $ \a ->+    either oB oC (split a)+  {-# INLINE choose #-}++-- | As a convenience, this type defines the @i@ to be a specific 'Json' structure:+type Encoder f a = EncoderFns Json f a++-- | As a convenience, this type defines the @i@ to be a specific 'JObject WS Json' structure:+type ObjEncoder f a = EncoderFns (JObject WS Json) f a++-- | As a convenience, this type is a pure Encoder over 'Identity' in place of the @f@.+type Encoder' a = EncoderFns Json Identity a+-- | As a convenience, this type is a pure ObjEncoder over 'Identity' in place of the @f@.+type ObjEncoder' a = EncoderFns (JObject WS Json) Identity a++-- | Run any encoder to the 'Json' representation, allowing for some+-- 'Applicative' context @f@.+runEncoder :: Functor f => EncoderFns i f a -> a -> f Json+runEncoder e = fmap (finaliseEncoding e) . initialEncoding e+{-# INLINE runEncoder #-}++-- | Run any encoder to the 'Json' representation, with the context specialised+-- to 'Identity' for convenience.+runPureEncoder :: EncoderFns i Identity a -> a -> Json+runPureEncoder e = runIdentity . fmap (finaliseEncoding e) . initialEncoding e+{-# INLINE runPureEncoder #-}++-- | Helper function for creating an 'Encoder', provides the default+-- 'finaliseEncoding' function for 'Json' encoders.+jsonEncoder :: (a -> f Json) -> EncoderFns Json f a+jsonEncoder = EncoderFns id+{-# INLINE jsonEncoder #-}++-- | Helper function for creating a JSON 'object' 'Encoder'. Provides the+-- default 'finaliseEncoding' function for completing the 'JObject' to the+-- necessary 'Json' type.+objEncoder :: (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a+objEncoder = EncoderFns (\o -> _JObj # (o, mempty))+{-# INLINE objEncoder #-}

@@ -39,8 +39,8 @@   , unconsCommaSep   ) where -import           Prelude                 (Eq, Int, Show (showsPrec), otherwise,-                                          showString, shows, (&&), (<=), (==))+import           Prelude                 (Eq, Int, Show (showsPrec),+                                          showString, shows, (&&), (==), (||))  import           Control.Applicative     (Applicative (..), liftA2, pure, (*>),                                           (<*), (<*>))@@ -318,12 +318,10 @@    ix _ _ c@(CommaSeparated _ Nothing) = pure c -  ix i f c@(CommaSeparated w (Just es))-    | i == 0 && es ^. elemsElems . to V.null =-      CommaSeparated w . Just <$> (es & elemsLast . traverse %%~ f)-    | i <= es ^. elemsElems . to length =-      CommaSeparated w . Just <$> (es & elemsElems . ix i . traverse %%~ f)-    | otherwise = pure c+  ix i f (CommaSeparated w (Just es)) = CommaSeparated w . Just <$>+    if i == 0 && es ^. elemsElems . to V.null || i == es ^. elemsElems . to length+    then es & elemsLast . traverse %%~ f+    else es & elemsElems . ix i . traverse %%~ f  -- | Convert a list of 'a' to a 'CommaSeparated' list, with no whitespace. fromList :: (Monoid ws, Semigroup ws) => [a] -> CommaSeparated ws a

@@ -17,11 +17,11 @@   , jArrayBuilder   ) where -import           Prelude                   (Eq, Show)+import           Prelude                   (Eq, Show, Int)  import           Control.Category          ((.)) import           Control.Error.Util        (note)-import           Control.Lens              (AsEmpty (..), Cons (..), Rewrapped,+import           Control.Lens              (AsEmpty (..), Cons (..), Rewrapped, Ixed (..), Index, IxValue,                                             Wrapped (..), cons, isn't, iso,                                             nearly, over, prism, to, ( # ),                                             (^.), (^?), _2, _Wrapped)@@ -83,6 +83,12 @@ instance (Semigroup ws, Monoid ws) => Monoid (JArray ws a) where   mempty = JArray mempty   mappend = (<>)++type instance IxValue (JArray ws a) = a+type instance Index (JArray ws a)   = Int++instance Ixed (JArray ws a) where+  ix i f (JArray cs) = JArray <$> ix i f cs  instance Bifunctor JArray where   bimap f g (JArray cs) = JArray (bimap f g cs)

@@ -23,22 +23,24 @@   , MapLikeObj   , toMapLikeObj   , fromMapLikeObj+  , _MapLikeObj      -- * Parser / Builder   , jObjectBuilder   , parseJObject   ) where -import           Prelude                   (Eq, Int, Show, elem, not, otherwise,-                                            (==))+import           Prelude                   (Eq, Int, Show, elem, fst, not,+                                            otherwise, (==))  import           Control.Applicative       ((<*), (<*>)) import           Control.Category          (id, (.))-import           Control.Lens              (AsEmpty (..), At (..), Index,-                                            IxValue, Ixed (..), Lens',-                                            Rewrapped, Wrapped (..), cons,-                                            isn't, iso, nearly, re, to, ( # ),-                                            (.~), (<&>), (^.), (^?), _Wrapped)+import           Control.Lens              (AsEmpty (..), At (..), Index, +                                            IxValue, Ixed (..), Lens', Prism',+                                            Rewrapped, Wrapped (..), cons, +                                            isn't, iso, nearly, prism', re, to,+                                            ( # ), (.~), (<&>), (^.), (^?),+                                            _Wrapped)  import           Control.Monad             (Monad) import           Data.Bifoldable           (Bifoldable (bifoldMap))@@ -201,6 +203,15 @@   { fromMapLikeObj :: JObject ws a -- ^ Access the underlying 'JObject'.   }   deriving (Eq, Show, Functor, Foldable, Traversable)++-- |+-- 'Prism' for working with a 'JObject' as a 'MapLikeObj'. This optic will keep+-- the first unique key on a given 'JObject' and this information is not+-- recoverable. If you want to create a 'MapLikeObj' from a 'JObject' and keep+-- what is removed, then use the 'toMapLikeObj' function.+--+_MapLikeObj :: (Semigroup ws, Monoid ws) => Prism' (JObject ws a) (MapLikeObj ws a)+_MapLikeObj = prism' fromMapLikeObj (Just . fst . toMapLikeObj)  instance MapLikeObj ws a ~ t => Rewrapped (MapLikeObj ws a) t 

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveFoldable         #-} {-# LANGUAGE DeriveFunctor          #-}-{-# LANGUAGE DeriveGeneric          #-} {-# LANGUAGE DeriveTraversable      #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}@@ -30,16 +29,22 @@   , jsonWSTraversal   , jtypeTraversal   , jtypeWSTraversal++  -- * Optics+  , oat+  , oix+  , aix   ) where  -import           Prelude                     (Eq, Show)+import           Prelude                     (Eq, Int, Show)  import           Control.Applicative         (pure, (<$>), (<*>), (<|>)) import           Control.Category            (id, (.)) import           Control.Lens                (Prism', Rewrapped, Traversal,-                                              Traversal', Wrapped (..), iso,-                                              prism, traverseOf, _Wrapped)+                                              Traversal', Wrapped (..), at, iso,+                                              ix, prism, traverseOf, _1,+                                              _Wrapped)  import           Control.Monad               (Monad) @@ -53,12 +58,14 @@ import           Data.Function               (flip) import           Data.Functor                (Functor (..)) import           Data.Monoid                 (Monoid (..))-import           Data.Semigroup              ((<>))+import           Data.Semigroup              (Semigroup, (<>)) import           Data.Traversable            (Traversable (..)) import           Data.Tuple                  (uncurry)  import           Data.ByteString.Builder     (Builder) import qualified Data.ByteString.Builder     as BB+import           Data.Maybe                  (Maybe)+import           Data.Text                   (Text)  import           Text.Parser.Char            (CharParsing, text) @@ -67,7 +74,7 @@ import           Waargonaut.Types.JNumber    (JNumber, jNumberBuilder,                                               parseJNumber) import           Waargonaut.Types.JObject    (JObject (..), jObjectBuilder,-                                              parseJObject)+                                              parseJObject, _MapLikeObj) import           Waargonaut.Types.JString    (JString, jStringBuilder,                                               parseJString) import           Waargonaut.Types.Whitespace (WS (..), parseWhitespace)@@ -75,10 +82,17 @@ -- $setup -- >>> :set -XOverloadedStrings -- >>> import Utils+-- >>> import Control.Lens -- >>> import Control.Monad (return) -- >>> import Data.Either (Either (..), isLeft)+-- >>> import Data.Function (($)) -- >>> import Waargonaut.Decode.Error (DecodeError) -- >>> import Data.Digit (HeXDigit)+-- >>> import qualified Waargonaut.Encode as E+-- >>> let intList = E.runPureEncoder (E.list E.int) [1,2,3]+-- >>> data Foo = Foo { fooA :: Int, fooB :: Text } deriving Show+-- >>> let encodeFoo = E.mapLikeObj $ \(Foo i t) -> E.atKey' "a" E.int i . E.atKey' "b" E.text t+-- >>> let obj = E.runPureEncoder encodeFoo (Foo 33 "Fred") ----  -- | Individual JSON Types and their trailing whitespace.@@ -212,6 +226,38 @@ jTypesBuilder s (JStr js tws)   = jStringBuilder js                             <> s tws jTypesBuilder s (JArr js tws)   = jArrayBuilder s waargonautBuilder js          <> s tws jTypesBuilder s (JObj jobj tws) = jObjectBuilder s waargonautBuilder jobj       <> s tws++-- |+-- A 'Control.Lens.Traversal'' over the 'a' at the given 'Text' key on a JSON object.+--+-- >>> E.simplePureEncodeNoSpaces E.json (obj & oat "c" ?~ E.runPureEncoder E.int 33)+-- "{\"c\":33,\"a\":33,\"b\":\"Fred\"}"+-- >>> E.simplePureEncodeNoSpaces E.json (obj & oat "d" ?~ E.runPureEncoder E.text "sally")+-- "{\"d\":\"sally\",\"a\":33,\"b\":\"Fred\"}"+--+oat :: (AsJType r ws a, Semigroup ws, Monoid ws) => Text -> Traversal' r (Maybe a)+oat k = _JObj . _1 . _MapLikeObj . at k++-- |+-- A 'Control.Lens.Traversal'' over the 'a' at the given 'Int' position in a JSON object.+--+-- >>> E.simplePureEncodeNoSpaces E.json (obj & oix 0 .~ E.runPureEncoder E.int 1)+-- "{\"a\":1,\"b\":\"Fred\"}"+-- >>> E.simplePureEncodeNoSpaces E.json (obj & oix 1 .~ E.runPureEncoder E.text "sally")+-- "{\"a\":33,\"b\":\"sally\"}"+oix :: (Semigroup ws, Monoid ws, AsJType r ws a) => Int -> Traversal' r a+oix i = _JObj . _1 . ix i++-- |+-- A 'Control.Lens.Traversal'' over the 'a' at the given 'Int' position in a JSON array.+--+-- >>> E.simplePureEncodeNoSpaces E.json ((E.runPureEncoder (E.list E.int) [1,2,3]) & aix 0 .~ E.runPureEncoder E.int 99)+-- "[99,2,3]"+-- >>> E.simplePureEncodeNoSpaces E.json ((E.runPureEncoder (E.list E.int) [1,2,3]) & aix 2 .~ E.runPureEncoder E.int 44)+-- "[1,2,44]"+aix :: (AsJType r ws a, Semigroup ws, Monoid ws) => Int -> Traversal' r a+aix i = _JArr . _1 . ix i+  -- | Parse a 'null' value. --

@@ -41,15 +41,47 @@  decoderTests :: TestTree decoderTests = testGroup "Decoding"-  [ testCase "Decode Image (test1.json)" decodeTest1Json-  , testCase "Decode [Int]" decodeTest2Json-  , testCase "Decode (Char,String,[Int])" decodeTest3Json-  , testCase "Decode Fail with Bad Key" decodeTestBadObjKey-  , testCase "Decode Fail with Missing Key" decodeTestMissingObjKey-  , testCase "Decode Enum and throwError" decodeTestEnumError-  , testCase "Decode Using Alt" decodeAlt-  , testCase "Decode Using Alt (Error) - Records BranchFail" decodeAltError+  [ testCase "Image (test1.json)" decodeTest1Json+  , testCase "[Int]" decodeTest2Json+  , testCase "(Char,String,[Int])" decodeTest3Json+  , testCase "Fail with Bad Key" decodeTestBadObjKey+  , testCase "Fail with Missing Key" decodeTestMissingObjKey+  , testCase "Enum and throwError" decodeTestEnumError+  , testCase "Using Alt" decodeAlt+  , testCase "Using Alt (Error) - Records BranchFail" decodeAltError+  , testCase "List Decoder" listDecoder+  , testCase "NonEmpty List Decoder" nonEmptyDecoder   ]++nonEmptyDecoder :: Assertion+nonEmptyDecoder = do+  let+    dec = D.runPureDecode (D.nonempty D.int) parseBS . D.mkCursor++    ok = "[1]"+    notOkay = "[]"++    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))++listDecoder :: Assertion+listDecoder = do+  let+    dec = D.runPureDecode (D.list D.int) parseBS . D.mkCursor++    ok = "[1,2,3]"+    okE = "[]"++    badShape = "{}"+    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 element decoder accepted" (Either.isLeft (dec badElem))  decodeTestMissingObjKey :: Assertion decodeTestMissingObjKey = do

@@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables        #-} module Decoder.Laws (decoderLaws) where -import           Control.Applicative     (Applicative, liftA3, pure)+import           Control.Applicative     (Applicative, pure) import           Control.Monad.Except    (throwError)  import           Data.Functor.Alt        (Alt ((<!>)))@@ -14,8 +14,6 @@ import           Test.Tasty.Hedgehog     (testProperty)  import           Hedgehog-import           Hedgehog.Function       (Arg, Vary)-import qualified Hedgehog.Function       as Fn import qualified Hedgehog.Gen            as Gen  import qualified Waargonaut.Decode       as D@@ -24,15 +22,12 @@  import           Types.Common            (parseBS) +import qualified Laws+ runD :: Decoder Identity a -> Either (DecodeError, D.CursorHistory) a runD d = D.runPureDecode d parseBS (D.mkCursor "true") -runSD :: ShowDecoder a -> Either (DecodeError, D.CursorHistory) a-runSD = runD . unShowDecoder--newtype ShowDecoder a = SD-  { unShowDecoder :: Decoder Identity a-  }+newtype ShowDecoder a = SD (Decoder Identity a)   deriving (Functor, Monad, Applicative)  instance Alt ShowDecoder where@@ -47,181 +42,33 @@ genShowDecoder :: Gen a -> Gen (ShowDecoder a) genShowDecoder genA = Gen.choice   [ SD . pure <$> genA-  , SD <$> Gen.constant (throwError $ ConversionFailure "Intentional DecodeError (TEST)")+  , SD        <$> Gen.constant (throwError $ ConversionFailure "Intentional DecodeError (TEST)")   ] --- |--- Alt Associative--- <!> is associative:             (a <!> b) <!> c = a <!> (b <!> c)----alt_associativity :: Property-alt_associativity = property $ do-  (a,b,c) <- forAll $ liftA3 (,,)-    (genShowDecoder Gen.bool)-    (genShowDecoder Gen.bool)-    (genShowDecoder Gen.bool)--  runSD ((a <!> b) <!> c) === runSD (a <!> (b <!> c))---- |--- Alt left distributes--- <$> left-distributes over <!>:  f <$> (a <!> b) = (f <$> a) <!> (f <$> b)-alt_left_distributes-  :: forall a b.-     ( Show a, Arg a, Vary a, Eq a-     , Show b, Arg b, Vary b, Eq b-     )-  => Gen a-  -> Gen b-  -> Property-alt_left_distributes genA genB = property $ do-  f <- Fn.forAllFn $ Fn.fn genA--  a <- forAll (genShowDecoder genB)-  b <- forAll (genShowDecoder genB)--  runSD ( f <$> (a <!> b) ) === runSD ( (f <$> a) <!> (f <$> b) )---- |--- identity------     pure id <*> v = v-applicative_id :: Property-applicative_id = property $ do-  a <- forAll (genShowDecoder Gen.bool)-  runSD (pure id <*> a) === runSD a---- |--- composition------     pure (.) <*> u <*> v <*> w = u <*> (v <*> w)-applicative_composition-  :: forall a b c.-     ( Show a, Arg a, Vary a, Eq a-     , Show b, Arg b, Vary b, Eq b-     , Show c, Arg c, Vary c-     )-  => Gen a-  -> Gen b-  -> Gen c-  -> Property-applicative_composition genA genB genC = property $ do-  u <- Fn.forAllFn $ Fn.fn genB-  v <- Fn.forAllFn $ Fn.fn genC--  w <- forAll (genShowDecoder genA)--  let-    dU = pure u-    dV = pure v--  runSD ( pure (.) <*> dU <*> dV <*> w ) === runSD ( dU <*> ( dV <*> w ) )---- |--- homomorphism------     pure f <*> pure x = pure (f x)-applicative_homomorphism-  :: forall a b.-     ( Show a, Arg a, Vary a, Eq a-     , Show b, Arg b, Vary b-     )-  => Gen a-  -> Gen b-  -> Property-applicative_homomorphism genA genB = property $ do-  f <- Fn.forAllFn $ Fn.fn genA-  x <- forAll genB--  runD (pure f <*> pure x) === runD (pure (f x))---- |--- interchange------     u <*> pure y = pure ($ y) <*> u-applicative_interchange-  :: forall u y.-     ( Show u, Arg u, Vary u, Eq u-     , Show y, Arg y, Vary y-     )-  => Gen u-  -> Gen y-  -> Property-applicative_interchange genU genY = property $ do-  u <- Fn.forAllFn $ Fn.fn genU-  y <- forAll genY--  let-    dU = pure u--  runD (dU <*> pure y) === runD (pure ($ y) <*> dU)---- |--- monad------    return a >>= k = k a-monad_return_bind-  :: forall a k.-     ( Show a, Arg a, Vary a, Eq a-     , Show k, Arg k, Vary k, Eq k-     )-  => Gen a-  -> Gen k-  -> Property-monad_return_bind genA genK = property $ do-  k' <- Fn.forAllFn $ Fn.fn genK-  a <- forAll genA--  let-    k = SD . pure . k'--  runSD (return a >>= k) === runSD (k a)---- |--- monad------     m >>= return  =  m-monad_bind_return :: Property-monad_bind_return = property $ do-  m <- forAll (genShowDecoder Gen.bool)--  runSD (m >>= return) === runSD m---- |--- monad------     m >>= (\x -> k x >>= h)  =  (m >>= k) >>= h-monad_associativity-  :: forall m k h.-     ( Show m, Arg m, Vary m, Eq m-     , Show k, Arg k, Vary k, Eq k-     , Show h, Arg h, Vary h, Eq h-     )-  => Gen m-  -> Gen k-  -> Gen h-  -> Property-monad_associativity genM genK genH = property $ do-  m <- forAll (genShowDecoder genM)+decoderLaws :: TestTree+decoderLaws = testGroup "Decoder Laws"+  [ testGroup "Applicative" -  k' <- Fn.forAllFn $ Fn.fn genK-  h' <- Fn.forAllFn $ Fn.fn genH+    [ testProperty "identity"     $ Laws.applicative_id genShowDecoder Gen.bool+    , testProperty "composition"  $ Laws.applicative_composition genShowDecoder Gen.bool Gen.bool Gen.bool+    , testProperty "homomorphism" $ Laws.applicative_homomorphism sdPure Gen.bool Gen.bool+    , testProperty "interchange"  $ Laws.applicative_interchange sdPure Gen.bool Gen.bool+    ] -  let-    k = SD . pure . k'-    h = SD . pure . h'+  , testGroup "Alt"+    [ testProperty "associativity"    $ Laws.alt_associativity genShowDecoder Gen.bool+    , testProperty "left distributes" $ Laws.alt_left_distributes genShowDecoder Gen.bool Gen.bool+    ] -  runSD (m >>= (\x -> k x >>= h)) === runSD ( (m >>= k) >>= h )+  , testGroup "Monad"+    [ testProperty "return a >>= k = k a" $ Laws.monad_return_bind genShowDecoder Gen.bool Gen.bool+    , testProperty "m >>= return = m"     $ Laws.monad_bind_return_id genShowDecoder Gen.bool+    , testProperty "associativity"        $ Laws.monad_associativity genShowDecoder Gen.bool Gen.bool Gen.bool+    ] -decoderLaws :: TestTree-decoderLaws = testGroup "Decoder Laws"-  [ testProperty "Applicative 'identity'" applicative_id-  , testProperty "Applicative 'composition'" $ applicative_composition Gen.bool Gen.bool Gen.bool-  , testProperty "Applicative 'homomorphism'" $ applicative_homomorphism Gen.bool Gen.bool-  , testProperty "Applicative 'interchange'" $ applicative_interchange Gen.bool Gen.bool-  , testProperty "Alt 'associativity'" alt_associativity-  , testProperty "Alt 'left distributes'" $ alt_left_distributes Gen.bool Gen.bool-  , testProperty "Monad 'return a >>= k = k a'" $ monad_return_bind Gen.bool Gen.bool-  , testProperty "Monad 'm >>= return = m'" monad_bind_return-  , testProperty "Monad 'associativity'" $ monad_associativity Gen.bool Gen.bool Gen.bool+  , testGroup "Functor"+    [ testProperty "'fmap compose'" $ Laws.fmap_compose genShowDecoder Gen.bool Gen.bool Gen.bool+    ]   ]+  where+    sdPure = (pure :: a -> ShowDecoder a)

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-}@@ -8,20 +7,24 @@   , testImageDataType   ) where -import           Test.Tasty           (TestName, TestTree, testGroup)-import           Test.Tasty.HUnit     (assertEqual, testCase)+import           Control.Lens          ((<&>), (?~)) -import           Data.Proxy           (Proxy (..))+import           Test.Tasty            (TestName, TestTree, testGroup)+import           Test.Tasty.HUnit      (testCase, (@?=)) -import           Waargonaut.Encode    (Encoder, Encoder')-import qualified Waargonaut.Encode    as E+import           Data.Proxy            (Proxy (..)) -import           Data.ByteString.Lazy (ByteString)+import           Waargonaut.Encode     (Encoder, Encoder')+import qualified Waargonaut.Encode     as E -import           Types.Common         (Image (..), testFudge, testImageDataType)+import           Data.ByteString.Lazy  (ByteString) -import           Waargonaut.Generic   (GWaarg, mkEncoder, proxy)+import           Types.Common          (Image (..), Overlayed (..), testFudge,+                                        testImageDataType) +import           Waargonaut.Generic    (GWaarg, mkEncoder, proxy)+import           Waargonaut.Types.Json (oat)+ testImageEncodedNoSpaces :: ByteString testImageEncodedNoSpaces = "{\"Width\":800,\"Height\":600,\"Title\":\"View from 15th Floor\",\"Animated\":false,\"IDs\":[116,943,234,38793]}" @@ -37,20 +40,33 @@ testFudgeEncodedWithConsName :: ByteString testFudgeEncodedWithConsName = "{\"fudgey\":\"Chocolate\"}" +testOverlayed :: Overlayed+testOverlayed = Overlayed "fred" testFudge++testOverlayedOut :: ByteString+testOverlayedOut = "{\"id\":\"fred\",\"fudgey\":\"Chocolate\"}"++encodeOverlay :: Applicative f => Encoder f Overlayed+encodeOverlay = E.encodeA $ \(Overlayed i f) -> E.runEncoder fudgeEnc f+  <&> oat "id" ?~ E.runPureEncoder E.text i+  where+    fudgeEnc = proxy mkEncoder (Proxy :: Proxy GWaarg)+ tCase   :: TestName   -> Encoder' a   -> a   -> ByteString   -> TestTree-tCase nm enc a =-  testCase nm . assertEqual nm (E.simplePureEncodeNoSpaces enc a)+tCase nm enc a expected = testCase nm $+  E.simplePureEncodeNoSpaces enc a @?= expected  encoderTests :: TestTree encoderTests = testGroup "Encoder"-  [ tCase "Encode Image" encodeImage testImageDataType testImageEncodedNoSpaces-  , tCase "Encode Image (Generic)" enc testImageDataType testImageEncodedNoSpaces-  , tCase "Encode newtype - with constructor name" enc testFudge testFudgeEncodedWithConsName+  [ tCase "Image" encodeImage testImageDataType testImageEncodedNoSpaces+  , tCase "Image (Generic)" enc testImageDataType testImageEncodedNoSpaces+  , tCase "newtype - with constructor name" enc testFudge testFudgeEncodedWithConsName+  , tCase "Overlayed" encodeOverlay testOverlayed testOverlayedOut   ]   where     enc = proxy mkEncoder (Proxy :: Proxy GWaarg)

@@ -2,20 +2,22 @@ {-# LANGUAGE RankNTypes       #-} module Encoder.Laws (encoderLaws) where -import           Test.Tasty            (TestTree, testGroup)-import           Test.Tasty.Hedgehog   (testProperty)+import           Test.Tasty                 (TestTree, testGroup)+import           Test.Tasty.Hedgehog        (testProperty) -import           Data.ByteString.Lazy  (ByteString)-import           Data.Functor.Identity (Identity)+import           Data.ByteString.Lazy       (ByteString)+import           Data.Functor.Contravariant (contramap)+import           Data.Functor.Identity      (Identity)  import           Hedgehog-import           Hedgehog.Function     (Arg, Vary)-import qualified Hedgehog.Function     as Fn-import qualified Hedgehog.Gen          as Gen+import qualified Hedgehog.Function          as Fn+import qualified Hedgehog.Gen               as Gen -import           Waargonaut.Encode     (Encoder)-import qualified Waargonaut.Encode     as E+import           Waargonaut.Encode          (Encoder)+import qualified Waargonaut.Encode          as E +import qualified Laws+ runSE :: ShowEncoder a -> a -> ByteString runSE (SE e) = E.simplePureEncodeNoSpaces e @@ -27,39 +29,15 @@ instance Fn.Contravariant ShowEncoder where   contramap f (SE a) = SE (Fn.contramap f a) --- |--- contravariant------     contramap f . contramap g = contramap (g . f)-contravariant_composition-  :: forall f a.-     ( Show f, Arg f, Vary f, Eq f-     , Show a, Arg a, Vary a-     )-  => Gen f-  -> Gen Bool-  -> Gen a-  -> Property-contravariant_composition genF genG genA = property $ do-  f <- Fn.forAllFn $ Fn.fn genF-  g <- Fn.forAllFn $ Fn.fn genG--  let ea = SE E.bool--  a <- forAll genA--  runSE (Fn.contramap f $ Fn.contramap g ea) a === runSE (Fn.contramap (g . f) ea) a--contravariant_identity :: Property-contravariant_identity = property $ do-  a <- forAll Gen.bool--  let ea = SE E.bool--  runSE (Fn.contramap id ea) a === runSE ea a+genShowEncoder :: Encoder Identity a -> Gen a -> Gen (ShowEncoder a)+genShowEncoder enc _ = Gen.constant (SE enc)  encoderLaws :: TestTree encoderLaws = testGroup "Encoder Laws"-  [ testProperty "Contravariant 'composition'" $ contravariant_composition Gen.bool Gen.bool Gen.bool-  , testProperty "Contravariant 'identity'" contravariant_identity+  [ testGroup "Contravariant"+    [ testProperty "composition"+      $ Laws.contravariant_composition_with_run (genShowEncoder E.bool) runSE Gen.bool (Gen.maybe Gen.bool) Gen.bool+    , testProperty "identity"+      $ Laws.contravariant_identity_with_run (genShowEncoder E.bool) runSE Gen.bool+    ]   ]

@@ -0,0 +1,351 @@+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Laws+  ( fmap_compose++  , alt_left_distributes+  , alt_associativity++  , applicative_id+  , applicative_composition+  , applicative_homomorphism+  , applicative_interchange++  , monad_return_bind+  , monad_bind_return_id+  , monad_associativity++  , contravariant_identity+  , contravariant_composition+  , contravariant_identity_with_run+  , contravariant_composition_with_run+  ) where++import           Control.Applicative        (liftA3)++import           Data.Functor.Alt           (Alt (..))+import           Data.Functor.Contravariant (Contravariant, contramap)++import           Hedgehog+import           Hedgehog.Function          (Arg, Vary)+import qualified Hedgehog.Function          as Fn++fmap_compose+  :: forall f a b c+   . ( Functor f+     , Show (f a)+     , Show a, Arg a, Vary a+     , Show b, Arg b, Vary b+     , Show c+     , Eq (f c)+     , Show (f c)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Gen b+  -> Gen c+  -> Property+fmap_compose genF genA genB genC = property $ do+  g <- Fn.forAllFn $ Fn.fn genB+  f <- Fn.forAllFn $ Fn.fn genC+  xs <- forAll $ genF genA+  fmap (f . g) xs === fmap f (fmap g xs)++-- |+-- Alt left distributes+-- <$> left-distributes over <!>:  f <$> (a <!> b) = (f <$> a) <!> (f <$> b)+alt_left_distributes+  :: forall a b f.+     ( Alt f+     , Show a, Arg a, Vary a, Eq a+     , Show b, Arg b, Vary b, Eq b+     , Show (f a), Eq (f a)+     , Show (f b)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Gen b+  -> Property+alt_left_distributes genF genA genB = property $ do+  f <- Fn.forAllFn $ Fn.fn genA++  a <- forAll (genF genB)+  b <- forAll (genF genB)++  (f <$> (a <!> b)) === ((f <$> a) <!> (f <$> b))++-- |+-- Alt Associative+-- <!> is associative:             (a <!> b) <!> c = a <!> (b <!> c)+--+alt_associativity+  :: forall f a.+     ( Alt f+     , Show (f a), Eq (f a)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Property+alt_associativity genF genA = property $ do+  (a,b,c) <- forAll $ liftA3 (,,)+    (genF genA)+    (genF genA)+    (genF genA)++  ((a <!> b) <!> c) === (a <!> (b <!> c))++-- |+-- identity+--+--     pure id <*> v = v+applicative_id+  :: forall f a.+     ( Applicative f+     , Show (f a)+     , Eq (f a)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Property+applicative_id genF genA = property $ do+  a <- forAll (genF genA)+  (pure id <*> a) === a++-- |+-- composition+--+--     pure (.) <*> u <*> v <*> w = u <*> (v <*> w)+applicative_composition+  :: forall f a b c.+     ( Show a, Arg a, Vary a, Eq a+     , Show b, Arg b, Vary b, Eq b+     , Show c, Arg c, Vary c+     , Show (f a)+     , Show (f b)+     , Show (f c)+     , Eq (f a)+     , Eq (f b)+     , Eq (f c)+     , Applicative f+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Gen b+  -> Gen c+  -> Property+applicative_composition genF genA genB genC = property $ do+  u <- Fn.forAllFn $ Fn.fn genB+  v <- Fn.forAllFn $ Fn.fn genC++  w <- forAll (genF genA)++  let+    dU = pure u+    dV = pure v++  ( pure (.) <*> dU <*> dV <*> w ) === ( dU <*> ( dV <*> w ) )++-- |+-- homomorphism+--+--     pure f <*> pure x = pure (f x)+applicative_homomorphism+  :: forall f a b.+     ( Show a, Arg a, Vary a, Eq a+     , Show b, Arg b, Vary b+     , Show (f a), Eq (f a)+     , Show (f a), Eq (f b)+     , Applicative f+     )+  => (forall x. x -> f x)+  -> Gen a+  -> Gen b+  -> Property+applicative_homomorphism pureF genA genB = property $ do+  f <- Fn.forAllFn $ Fn.fn genA+  x <- forAll genB++  (pureF f <*> pureF x) === (pureF (f x))++-- |+-- interchange+--+--     u <*> pure y = pure ($ y) <*> u+applicative_interchange+  :: forall f u y.+     ( Applicative f+     , Show u, Arg u, Vary u, Eq u+     , Show y, Arg y, Vary y+     , Show (f u), Eq (f u)+     , Show (f y), Eq (f y)+     )+  => (forall x. x -> f x)+  -> Gen u+  -> Gen y+  -> Property+applicative_interchange pureF genU genY = property $ do+  u <- Fn.forAllFn $ Fn.fn genU+  y <- forAll genY++  let+    dU = pureF u++  (dU <*> pure y) === (pure ($ y) <*> dU)++-- |+-- monad+--+--    return a >>= k = k a+monad_return_bind+  :: forall f a k.+     ( Monad f+     , Show a, Arg a, Vary a, Eq a+     , Show k, Arg k, Vary k, Eq k+     , Show (f a), Eq (f a)+     , Show (f k), Eq (f k)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Gen k+  -> Property+monad_return_bind genF genA genK = property $ do+  k <- Fn.forAllFn $ Fn.fn (genF genK)+  a <- forAll genA++  (return a >>= k) === (k a)++-- |+-- monad+--+--     m >>= return  =  m+monad_bind_return_id+  :: forall f a.+     ( Monad f+     , Show a, Eq a+     , Show (f a), Eq (f a)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Property+monad_bind_return_id genF genA = property $ do+  m <- forAll (genF genA)++  (m >>= return) === m++-- |+-- monad+--+--     m >>= (\x -> k x >>= h)  =  (m >>= k) >>= h+monad_associativity+  :: forall f m k h.+     ( Monad f+     , Show m, Arg m, Vary m, Eq m+     , Show k, Arg k, Vary k, Eq k+     , Show h, Arg h, Vary h, Eq h+     , Show (f m), Eq (f m)+     , Show (f k), Eq (f k)+     , Show (f h), Eq (f h)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen m+  -> Gen k+  -> Gen h+  -> Property+monad_associativity genF genM genK genH = property $ do+  m <- forAll (genF genM)++  k <- Fn.forAllFn $ Fn.fn (genF genK)+  h <- Fn.forAllFn $ Fn.fn (genF genH)++  (m >>= (\x -> k x >>= h)) === ( (m >>= k) >>= h )++-- |+-- contravariant+--+--     contramap f . contramap g = contramap (g . f)+contravariant_composition+  :: forall f a b c.+     ( Contravariant f+     , Show a, Arg a, Vary a, Eq (f a), Show (f a)+     , Show b, Arg b, Vary b, Eq b+     , Show c, Show (f c)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Gen b+  -> Gen c+  -> Property+contravariant_composition genF _genA genB genC = property $ do+  f <- Fn.forAllFn $ (Fn.fn genB :: Gen (Fn.Fn a b))+  g <- Fn.forAllFn $ (Fn.fn genC :: Gen (Fn.Fn b c))++  fc <- forAll (genF genC)++  (contramap f . contramap g) fc === contramap (g . f) fc++-- |+-- contravariant+--+--     contramap id a = a+contravariant_identity+  :: forall f a.+     ( Contravariant f+     , Show a, Arg a, Vary a+     , Show (f a)+     , Eq (f a)+     )+  => (forall x. Gen x -> Gen (f x))+  -> Gen a+  -> Property+contravariant_identity genF genA = property $ do+  a <- forAll (genF genA)++  contramap id a === a++-- |+-- contravariant+--+--     contramap f . contramap g = contramap (g . f)+contravariant_composition_with_run+  :: forall f a b c x.+     ( Contravariant f+     , Show a, Arg a, Vary a+     , Show b, Arg b, Vary b, Eq b+     , Show c, Show (f c)+     , Eq x, Show x+     )+  => (Gen c -> Gen (f c))+  -> (f a -> a -> x)+  -> Gen a+  -> Gen b+  -> Gen c+  -> Property+contravariant_composition_with_run genF runF genA genB genC = property $ do+  f <- Fn.forAllFn $ (Fn.fn genB :: Gen (Fn.Fn a b))+  g <- Fn.forAllFn $ (Fn.fn genC :: Gen (Fn.Fn b c))++  a <- forAll genA+  fc <- forAll (genF genC)++  runF ((contramap f . contramap g) fc) a === runF (contramap (g . f) fc) a++-- |+-- contravariant+--+--     contramap id a = a+contravariant_identity_with_run+  :: forall f a b.+     ( Contravariant f+     , Show a, Arg a, Vary a, Eq a+     , Show b, Eq b+     , Show (f a)+     )+  => (Gen a -> Gen (f a))+  -> (f a -> a -> b)+  -> Gen a+  -> Property+contravariant_identity_with_run genF runF genA = property $ do+  fa <- forAll (genF genA)+  a <- forAll genA++  runF (contramap id fa) a === runF fa a

@@ -31,6 +31,7 @@   , Image (..)   , Fudge (..)   , HasImage (..)+  , Overlayed (..)   ) where  import           Generics.SOP                (Generic, HasDatatypeInfo)@@ -161,6 +162,13 @@  testFudge :: Fudge testFudge = Fudge "Chocolate"++data Overlayed = Overlayed+  { _overId :: Text+  , _overFu :: Fudge+  }+  deriving (Show, GHC.Generic)+ genDecimalDigit :: Gen DecDigit genDecimalDigit = Gen.element decimalDigit 

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.3.0.0+version:             0.4.0.0  -- A short (one-line) description of the package. synopsis:            JSON wrangling@@ -88,6 +88,7 @@                      , Waargonaut.Decode.ZipperMove                      , Waargonaut.Decode.Error                      , Waargonaut.Decode.Types+                     , Waargonaut.Encode.Types                       , Waargonaut.Decode                      , Waargonaut.Decode.Traversal@@ -167,6 +168,7 @@                      , Types.Json                      , Types.Whitespace +                     , Laws                      , Utils                      , Encoder                      , Encoder.Laws@@ -200,6 +202,7 @@                      , semigroupoids          >= 5.2.2  && < 6                      , containers             >= 0.5.6  && < 0.7                      , natural                >= 0.3    && < 4+                     , contravariant       >= 1.4     && < 2                       , waargonaut