Merge pull request #26 from qfpl/add-oneof-decoder

Add new decoder and tests

changelog.md

@@ -1,5 +1,9 @@
 # Revision history for waargonaut
 
+## 0.4.1.0  -- 2018-11-20
+
+* Add `oneOf` decoder and tests
+
 ## 0.4.0.0  -- 2018-11-19
 
 * Redesign & rebuild of `Encoder` internals to allow for greater control and flexibility

src/Waargonaut/Decode.hs

@@ -77,6 +77,7 @@ module Waargonaut.Decode
   , withDefault
   , maybeOrNull
   , either
+  , oneOf
 
   ) where
 
@@ -90,7 +91,7 @@ import           Control.Lens                              (Cons, Lens', Prism',
                                                             (^.), _Wrapped)
 
 import           Prelude                                   (Bool, Bounded, Char,
-                                                            Int, Integral,
+                                                            Eq, Int, Integral,
                                                             String,
                                                             fromIntegral, (-),
                                                             (==))
@@ -110,15 +111,15 @@ import           Control.Error.Util                        (note)
 import           Control.Monad.Error.Hoist                 ((<!?>), (<?>))
 
 import           Data.Either                               (Either (..))
-import           Data.Foldable                             (foldl)
+import           Data.Foldable                             (Foldable, foldl,
+                                                            foldr)
 import           Data.Function                             (const, flip, ($),
                                                             (&))
 import           Data.Functor                              (fmap, (<$), (<$>))
 import           Data.Functor.Alt                          ((<!>))
 import           Data.Functor.Identity                     (Identity,
                                                             runIdentity)
 import           Data.Monoid                               (mempty)
-
 import           Data.Scientific                           (Scientific)
 
 import           Data.List.NonEmpty                        (NonEmpty ((:|)))
@@ -500,7 +501,7 @@ atCursor m c = withCursor $ \curs -> do
 -- movements. This lets you combine arbitrary cursor movements with an accumulating
 -- function.
 --
--- The functions 'leftwardCons' and 'rightwardSnoc' are both impelemented using
+-- The functions 'leftwardCons' and 'rightwardSnoc' are both implemented using
 -- this function.
 --
 -- @
@@ -525,6 +526,49 @@ foldCursor nom f s elemD curs = DecodeResult . ReaderT $ \p ->
     (DI.Decoder' $ runDecoder elemD p)
     curs
 
+-- | 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
+-- fail. Normally it would simply be the name of the type you are writing the
+-- decoder for.
+--
+-- This is useful for decoding sum types, such as:
+--
+-- @
+-- data MyEnum
+--   = A
+--   | B
+--   | C
+--
+-- decodeMyEnum :: Monad f => Decoder f MyEnum
+-- decodeMyEnum = D.oneOf D.text "MyEnum"
+--   [ ("a", A)
+--   , ("b", B)
+--   , ("c", C)
+--   ]
+--
+-- decodeMyEnumFromInt :: Monad f => Decoder f MyEnum
+-- decodeMyEnumFromInt = D.oneOf D.int "MyEnum"
+--   [ (1, A)
+--   , (2, B)
+--   , (3, C)
+--   ]
+-- @
+--
+oneOf
+  :: ( Foldable g
+     , Monad f
+     , Eq a
+     )
+  => Decoder f a
+  -> Text
+  -> g (a, b)
+  -> Decoder f b
+oneOf d l =
+  foldr (\i x -> g i <!> x) err
+  where
+    g (a,b) = d >>= \t -> if t == a then pure b else err
+    err = throwError (ConversionFailure l)
+
 -- | From the current cursor position, move leftwards one position at a time and
 -- push each 'a' onto the front of some 'Cons' structure.
 leftwardCons

test/Decoder.hs

@@ -8,10 +8,9 @@ module Decoder
 import           Prelude                    (Char, Eq, Int, Show, String, print,
                                              (==))
 
-import           Control.Applicative        (liftA3, pure, (<$>))
+import           Control.Applicative        (liftA3, (<$>))
 import           Control.Category           ((.))
 import           Control.Monad              (Monad, (>=>), (>>=))
-import           Control.Monad.Except       (throwError)
 
 import           Test.Tasty                 (TestTree, testGroup)
 import           Test.Tasty.HUnit           (Assertion, assertBool, assertEqual,
@@ -46,6 +45,7 @@ decoderTests = testGroup "Decoding"
   , testCase "(Char,String,[Int])" decodeTest3Json
   , testCase "Fail with Bad Key" decodeTestBadObjKey
   , testCase "Fail with Missing Key" decodeTestMissingObjKey
+  , testCase "Enum" decodeTestEnum
   , testCase "Enum and throwError" decodeTestEnumError
   , testCase "Using Alt" decodeAlt
   , testCase "Using Alt (Error) - Records BranchFail" decodeAltError
@@ -145,11 +145,20 @@ data MyEnum
   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")
+decodeMyEnum = D.oneOf D.text "MyEnum"
+  [ ("a", A)
+  , ("b", B)
+  , ("c", C)
+  ]
+
+decodeTestEnum :: Assertion
+decodeTestEnum = do
+  chk "\"a\"" A
+  chk "\"b\"" B
+  chk "\"c\"" C
+  where
+    chk i o =
+      D.runPureDecode decodeMyEnum parseBS (D.mkCursor i) @?= (Either.Right o)
 
 decodeTestEnumError :: Assertion
 decodeTestEnumError = D.runDecode decodeMyEnum parseBS (D.mkCursor "\"WUT\"")

waargonaut.cabal

@@ -10,7 +10,7 @@ name:                waargonaut
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.4.0.0
+version:             0.4.1.0
 
 -- A short (one-line) description of the package.
 synopsis:            JSON wrangling

waargonaut.nix

@@ -10,7 +10,7 @@
 }:
 mkDerivation {
   pname = "waargonaut";
-  version = "0.4.0.0";
+  version = "0.4.1.0";
   src = ./.;
   setupHaskellDepends = [ base Cabal cabal-doctest ];
   libraryHaskellDepends = [