diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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`. diff --git a/src/Waargonaut/Decode.hs b/src/Waargonaut/Decode.hs --- a/src/Waargonaut/Decode.hs +++ b/src/Waargonaut/Decode.hs @@ -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 diff --git a/src/Waargonaut/Decode/Internal.hs b/src/Waargonaut/Decode/Internal.hs --- a/src/Waargonaut/Decode/Internal.hs +++ b/src/Waargonaut/Decode/Internal.hs @@ -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) 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 @@ -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) diff --git a/src/Waargonaut/Decode/ZipperMove.hs b/src/Waargonaut/Decode/ZipperMove.hs --- a/src/Waargonaut/Decode/ZipperMove.hs +++ b/src/Waargonaut/Decode/ZipperMove.hs @@ -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')) diff --git a/src/Waargonaut/Encode.hs b/src/Waargonaut/Encode.hs --- a/src/Waargonaut/Encode.hs +++ b/src/Waargonaut/Encode.hs @@ -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 diff --git a/test/Decoder.hs b/test/Decoder.hs --- a/test/Decoder.hs +++ b/test/Decoder.hs @@ -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") diff --git a/test/Decoder/Laws.hs b/test/Decoder/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Decoder/Laws.hs @@ -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 + ] diff --git a/test/Encoder/Laws.hs b/test/Encoder/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Encoder/Laws.hs @@ -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 + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] 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.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