waargonaut 0.2.0.2 → 0.2.1.0
raw patch · 11 files changed
+419/−29 lines, 11 filesdep +hedgehog-fndep +semigroupoids
Dependencies added: hedgehog-fn, semigroupoids
Files
- changelog.md +6/−0
- src/Waargonaut/Decode.hs +9/−9
- src/Waargonaut/Decode/Internal.hs +2/−2
- src/Waargonaut/Decode/Types.hs +17/−2
- src/Waargonaut/Decode/ZipperMove.hs +8/−6
- src/Waargonaut/Encode.hs +15/−4
- test/Decoder.hs +57/−5
- test/Decoder/Laws.hs +227/−0
- test/Encoder/Laws.hs +65/−0
- test/Main.hs +5/−0
- waargonaut.cabal +8/−1
changelog.md view
@@ -1,5 +1,11 @@ # Revision history for waargonaut +## 0.2.1.0 -- 2018-11-13++* Add `MonadError` and `Alt` instance for `Decoder`+* Add property tests for the typeclass laws for `Encoder` and `Decoder`+* Removed need for `MonadError` constraint on `prismDOrFail`+ ## 0.2.0.2 -- 2018-11-12 * Fix `Applicative` instance for `Decoder`.
src/Waargonaut/Decode.hs view
@@ -86,8 +86,8 @@ Snoc, cons, lens, modifying, preview, snoc, traverseOf,- view, (.~), (^.), (#),- _Wrapped)+ view, ( # ), (.~),+ (^.), _Wrapped) import Prelude (Bool, Bounded, Char, Int, Integral,@@ -100,15 +100,14 @@ import Control.Monad (Monad (..), (>=>)) import Control.Monad.Morph (embed, generalize) -import Control.Monad.Except (MonadError, lift,- liftEither,+import Control.Monad.Except (lift, liftEither, throwError) import Control.Monad.Reader (ReaderT (..), ask, local, runReaderT) import Control.Monad.State (MonadState) import Control.Error.Util (note)-import Control.Monad.Error.Hoist ((<?>),(<!?>))+import Control.Monad.Error.Hoist ((<!?>), (<?>)) import Data.Either (Either (..)) import Data.Foldable (foldl)@@ -148,7 +147,8 @@ import qualified HaskellWorks.Data.Json.Cursor as JC -import Waargonaut.Decode.Error (DecodeError (..), AsDecodeError (..),+import Waargonaut.Decode.Error (AsDecodeError (..),+ DecodeError (..), Err (..)) import Waargonaut.Decode.ZipperMove (ZipperMove (..)) @@ -653,13 +653,13 @@ -- | As per 'prismD' but fail the 'Decoder' if unsuccessful. prismDOrFail- :: MonadError DecodeError f+ :: Monad f => DecodeError -> Prism' a b -> Decoder f a -> Decoder f b-prismDOrFail e p d = Decoder $ \pf ->- DI.prismDOrFail' e p (DI.Decoder' $ runDecoder d pf)+prismDOrFail e p d = withCursor $+ focus d >=> \a -> preview p a <?> e -- | Decode an 'Int'. int :: Monad f => Decoder f Int
src/Waargonaut/Decode/Internal.hs view
@@ -3,9 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-} -- | Internal types and functions for building Decoder infrastructure. module Waargonaut.Decode.Internal ( CursorHistory' (..)@@ -54,7 +54,7 @@ import Control.Monad.State (MonadState (..), StateT (..)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Error.Hoist ((<!?>))+import Control.Monad.Error.Hoist ((<!?>)) import Control.Monad.Morph (MFunctor (..), MMonad (..)) import Data.Bifunctor (first)
src/Waargonaut/Decode/Types.hs view
@@ -18,7 +18,7 @@ import Control.Lens (Rewrapped, Wrapped (..), iso)-import Control.Monad.Except (MonadError)+import Control.Monad.Except (MonadError (..)) import Control.Monad.Morph (MFunctor (..), MMonad (..)) import Control.Monad.Reader (MonadReader,@@ -26,6 +26,9 @@ import Control.Monad.State (MonadState) import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Functor.Alt (Alt (..))+import qualified Data.Text as Text+ import GHC.Word (Word64) import Data.ByteString (ByteString)@@ -38,7 +41,9 @@ import Waargonaut.Decode.Internal (CursorHistory', DecodeError (..),- DecodeResultT (..))+ DecodeResultT (..),+ ZipperMove (BranchFail),+ recordZipperMove) import Waargonaut.Types (Json) @@ -68,11 +73,21 @@ aToB <*> a = Decoder $ \p c -> runDecoder aToB p c <*> runDecoder a p c +instance Monad f => Alt (Decoder f) where+ a <!> b = Decoder $ \p c -> catchError (runDecoder a p c) $ \e -> do+ recordZipperMove (BranchFail . Text.pack $ show e) (cursorRank $ unJCurs c)+ runDecoder b p c+ instance Monad f => Monad (Decoder f) where return = pure a >>= aToFb = Decoder $ \p c -> do r <- runDecoder a p c runDecoder (aToFb r) p c++instance Monad f => MonadError DecodeError (Decoder f) where+ throwError e = Decoder (\_ _ -> throwError e)+ catchError d handle = Decoder $ \p c ->+ catchError (runDecoder d p c) (\e -> runDecoder (handle e) p c) instance MFunctor Decoder where hoist nat (Decoder pjdr) = Decoder (\p -> hoist nat . pjdr p)
src/Waargonaut/Decode/ZipperMove.hs view
@@ -27,20 +27,22 @@ | Item Text | L Natural | R Natural+ | BranchFail Text deriving (Show, Eq) -- | Pretty print a given zipper movement, used when printing -- 'Waargonaut.Decode.Internal.CursorHistory'' to improve the readability of the errors. ppZipperMove :: ZipperMove -> Doc a ppZipperMove m = case m of- U -> WL.text "up/"- D -> WL.text "down\\"+ U -> WL.text "up/"+ D -> WL.text "down\\" - (L n) -> WL.text "-<-" <+> ntxt n- (R n) -> WL.text "->-" <+> ntxt n+ (L n) -> WL.text "-<-" <+> ntxt n+ (R n) -> WL.text "->-" <+> ntxt n - (DAt k) -> WL.text "into\\" <+> itxt "key" k- (Item t) -> WL.text "-::" <+> itxt "item" t+ (DAt k) -> WL.text "into\\" <+> itxt "key" k+ (Item t) -> WL.text "-::" <+> itxt "item" t+ (BranchFail t) -> WL.text "(attempted: " <+> ntxt t <+> WL.text ")" where itxt t k' = WL.parens (WL.text t <+> WL.colon <+> WL.text (Text.unpack k')) ntxt n' = WL.parens (WL.char 'i' <+> WL.char '+' <+> WL.text (show n'))
src/Waargonaut/Encode.hs view
@@ -25,6 +25,7 @@ -- * Provided encoders , int+ , integral , scientific , bool , text@@ -55,6 +56,7 @@ -- * Encoders specialised to Identity , int'+ , integral' , scientific' , bool' , text'@@ -81,11 +83,12 @@ import Control.Category (id, (.)) import Control.Lens (AReview, At, Index, IxValue, Prism', Rewrapped, Wrapped (..),- at, cons, iso, ( # ), (?~), _Empty,- _Wrapped)+ at, cons, iso, review, ( # ), (?~),+ _Empty, _Wrapped) import qualified Control.Lens as L -import Prelude (Bool, Int, Monad)+import Prelude (Bool, Int, Integral, Monad,+ fromIntegral) import Data.Foldable (Foldable, foldr, foldrM) import Data.Function (const, flip, ($), (&))@@ -190,7 +193,7 @@ -> (a -> b) -> Encoder f a encToJsonNoSpaces c f =- encodeA (pure . (c #) . (,mempty) . f)+ encodeA (pure . review c . (,mempty) . f) -- | Build an 'Encoder' using a 'Control.Lens.Prism'' prismE@@ -208,6 +211,10 @@ scientific :: Applicative f => Encoder f Scientific scientific = encToJsonNoSpaces _JNum (_JNumberScientific #) +-- | Encode a numeric value of the typeclass 'Integral'+integral :: (Applicative f, Integral n) => Encoder f n+integral = encToJsonNoSpaces _JNum (review _JNumberScientific . fromIntegral)+ -- | Encode a 'Bool' bool :: Applicative f => Encoder f Bool bool = encToJsonNoSpaces _JBool id@@ -292,6 +299,10 @@ -- | As per 'int' but with the 'f' specialised to 'Data.Functor.Identity'. int' :: Encoder' Int int' = int++-- | As per 'integral' but with the 'f' specialised to 'Data.Functor.Identity'.+integral' :: Integral n => Encoder' n+integral' = integral -- | As per 'scientific' but with the 'f' specialised to 'Data.Functor.Identity'. scientific' :: Encoder' Scientific
test/Decoder.hs view
@@ -1,27 +1,35 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Decoder ( decoderTests ) where -import Prelude (Char, Int, String, print, (==))+import Prelude (Char, Eq, Int, Show, String, print,+ (==)) -import Control.Applicative (liftA3, (<$>))+import Control.Applicative (liftA3, pure, (<$>)) import Control.Category ((.)) import Control.Monad (Monad, (>=>), (>>=))+import Control.Monad.Except (throwError) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertEqual,- assertFailure, testCase)+ assertFailure, testCase, (@?=)) +import Data.Bool (Bool (..)) import qualified Data.ByteString as BS import qualified Data.Either as Either-import Data.Function (($))+import Data.Function (const, ($))+import Data.Functor.Alt ((<!>))+import qualified Data.Sequence as Seq import Data.Tagged (untag)+import Data.Text (Text) import Waargonaut.Generic (mkDecoder) -import Waargonaut.Decode.Internal (ppCursorHistory)+import Waargonaut.Decode.Internal (ZipperMove (BranchFail),+ ppCursorHistory, unCursorHistory') import qualified Waargonaut.Decode as D import qualified Waargonaut.Decode.Error as D@@ -36,6 +44,9 @@ , 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 ] decodeTestMissingObjKey :: Assertion@@ -92,3 +103,44 @@ (D.focus D.unboundedChar fstElem) (D.moveRight1 fstElem >>= D.focus D.string) (D.moveRightN 2 fstElem >>= D.rightwardSnoc [] D.int)++data MyEnum+ = A+ | B+ | C+ deriving (Eq, Show)++decodeMyEnum :: Monad f => D.Decoder f MyEnum+decodeMyEnum = D.text >>= \case+ "a" -> pure A+ "b" -> pure B+ "c" -> pure C+ _ -> throwError (D.ConversionFailure "MyEnum")++decodeTestEnumError :: Assertion+decodeTestEnumError = D.runDecode decodeMyEnum parseBS (D.mkCursor "\"WUT\"")+ >>= Either.either+ (\(e, _) -> assertBool "Incorrect Error!" (e == D.ConversionFailure "MyEnum"))+ (const (assertFailure "Should not succeed"))++decodeEitherAlt :: Monad f => D.Decoder f (Either.Either Text Int)+decodeEitherAlt = (Either.Left <$> D.text) <!> (Either.Right <$> D.int)++decodeAlt :: Assertion+decodeAlt = do+ t <- D.runDecode decodeEitherAlt parseBS (D.mkCursor "\"FRED\"")+ i <- D.runDecode decodeEitherAlt parseBS (D.mkCursor "33")++ t @?= Either.Right (Either.Left "FRED")+ i @?= Either.Right (Either.Right 33)++decodeAltError :: Assertion+decodeAltError = D.runDecode decodeEitherAlt parseBS (D.mkCursor "{\"foo\":33}")+ >>= Either.either+ (\(_,h) -> assertBool "BranchFail error not found in history" $+ case Seq.viewr (unCursorHistory' h) of+ _ Seq.:> (BranchFail _, _) -> True+ _ -> False++ )+ (\_ -> assertFailure "Alt Error Test should fail")
+ test/Decoder/Laws.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Decoder.Laws (decoderLaws) where++import Control.Applicative (Applicative, liftA3, pure)+import Control.Monad.Except (throwError)++import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Identity (Identity)++import Test.Tasty (TestTree, testGroup)+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+import Waargonaut.Decode.Error (DecodeError (ConversionFailure))+import Waargonaut.Decode.Types (Decoder)++import Types.Common (parseBS)++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+ }+ deriving (Functor, Monad, Applicative)++instance Alt ShowDecoder where+ (SD a) <!> (SD b) = SD (a <!> b)++instance Eq a => Eq (ShowDecoder a) where+ (SD a) == (SD b) = runD a == runD b++instance Show a => Show (ShowDecoder a) where+ show (SD d) = show $ runD d++genShowDecoder :: Gen a -> Gen (ShowDecoder a)+genShowDecoder genA = Gen.choice+ [ SD . pure <$> genA+ , 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)++ k' <- Fn.forAllFn $ Fn.fn genK+ h' <- Fn.forAllFn $ Fn.fn genH++ let+ k = SD . pure . k'+ h = SD . pure . h'++ runSD (m >>= (\x -> k x >>= h)) === runSD ( (m >>= k) >>= h )++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+ ]
+ test/Encoder/Laws.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+module Encoder.Laws (encoderLaws) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Data.ByteString.Lazy (ByteString)+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 Waargonaut.Encode (Encoder)+import qualified Waargonaut.Encode as E++runSE :: ShowEncoder a -> a -> ByteString+runSE (SE e) = E.simplePureEncodeNoSpaces e++newtype ShowEncoder a = SE (Encoder Identity a)++instance Show a => Show (ShowEncoder a) where+ show (SE _) = "an encoder of type a"++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++encoderLaws :: TestTree+encoderLaws = testGroup "Encoder Laws"+ [ testProperty "Contravariant 'composition'" $ contravariant_composition Gen.bool Gen.bool Gen.bool+ , testProperty "Contravariant 'identity'" contravariant_identity+ ]
test/Main.hs view
@@ -50,7 +50,9 @@ import qualified Types.Whitespace as WS import qualified Decoder+import qualified Decoder.Laws import qualified Encoder+import qualified Encoder.Laws encodeText :: Json@@ -246,4 +248,7 @@ , Decoder.decoderTests , Encoder.encoderTests++ , Decoder.Laws.decoderLaws+ , Encoder.Laws.encoderLaws ]
waargonaut.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.2+version: 0.2.1.0 -- A short (one-line) description of the package. synopsis: JSON wrangling@@ -130,6 +130,7 @@ , hw-rankselect >= 0.10 && < 0.13 , hw-bits >= 0.7 && < 0.8 , tagged >= 0.8.6 && < 0.9+ , semigroupoids >= 5.2.2 && < 6 -- Directories containing source files. hs-source-dirs: src@@ -167,7 +168,9 @@ , Utils , Encoder+ , Encoder.Laws , Decoder+ , Decoder.Laws type: exitcode-stdio-1.0 main-is: Main.hs@@ -178,6 +181,7 @@ , tasty-hunit >= 0.10 && < 0.11 , tasty-expected-failure >= 0.11 && < 0.12 , hedgehog >= 0.6 && < 0.7+ , hedgehog-fn >= 0.6 && < 0.7 , tasty-hedgehog >= 0.2 && < 0.3 , lens >= 4.15 && < 5 , distributive >= 0.5 && < 0.7@@ -191,6 +195,9 @@ , attoparsec >= 0.13 && < 0.15 , scientific >= 0.3 && < 0.4 , tagged >= 0.8.6 && < 0.9+ , mtl >= 2.2.2 && < 3+ , semigroupoids >= 5.2.2 && < 6+ , containers >= 0.5.6 && < 0.7 , waargonaut