Fixes & tests

Author: m-bock

src/Data/Codec/Argonaut/Sum.purs

@@ -19,8 +19,7 @@ module Data.Codec.Argonaut.Sum
   , sumFlatWith
   , sumWith
   , taggedSum
-  )
-  where
+  ) where
 
 import Prelude
 
@@ -310,8 +309,7 @@ checkTag tagKey obj expectedTag = do
     ) ∷ _ Json
   tag ← CA.decode CA.string val # lmap JErr ∷ _ String
   when (tag /= expectedTag)
-    $ Left
-    $ NoCase
+    (Left NoCase)
 
 parseNoFields ∷ Encoding → Json → String → Either Err Unit
 parseNoFields encoding json expectedTag =
@@ -377,8 +375,7 @@ parseManyFields encoding json expectedTag =
     EncodeNested {} → do
       obj ← lmap JErr $ CA.decode jobject json
       val ←
-        ( Obj.lookup expectedTag obj
-            # note (JErr $ TypeMismatch ("Expecting a property `" <> expectedTag <> "`"))
+        ( Obj.lookup expectedTag obj # note NoCase
         ) ∷ _ Json
       lmap JErr $ CA.decode CA.jarray val
 
@@ -464,15 +461,11 @@ instance gFlatCasesConstructorNoArg ∷
   gFlatCasesDecode _ json = do
     let
       name = reflectSymbol (Proxy @name) ∷ String
+      tag = reflectSymbol (Proxy @tag) ∷ String
 
-      propCodec = CAR.record {} ∷ JPropCodec {}
-      propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf)
-      codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf)
-    r ← lmap JErr $ CA.decode codecWithTag json ∷ _ (Record rf)
-    let actualTag = Record.get (Proxy @tag) r ∷ String
+    obj ← lmap JErr $ CA.decode jobject json
 
-    when (actualTag /= name)
-      $ Left NoCase
+    checkTag tag obj name
 
     pure (Constructor NoArguments)
 
@@ -499,17 +492,19 @@ instance gFlatCasesConstructorSingleArg ∷
   gFlatCasesDecode rc json = do
     let
       name = reflectSymbol (Proxy @name) ∷ String
+      tag = reflectSymbol (Proxy @tag) ∷ String
+
+    obj ← lmap JErr $ CA.decode jobject json
+
+    checkTag tag obj name
+
+    let
       propCodec = Record.get (Proxy @name) rc ∷ JPropCodec (Record rf)
-      propCodecWithTag = CA.recordProp (Proxy @tag) CA.string propCodec ∷ JPropCodec (Record rf')
-      codecWithTag = CA.object ("case " <> name) propCodecWithTag ∷ JsonCodec (Record rf')
-    r ← lmap JErr $ CA.decode codecWithTag json ∷ _ (Record rf')
+      codec = CA.object ("case " <> name) propCodec ∷ JsonCodec (Record rf)
 
-    let actualTag = Record.get (Proxy @tag) r ∷ String
-    when (actualTag /= name)
-      $ Left NoCase
+    r ← lmap JErr $ CA.decode codec json ∷ _ (Record rf)
 
-    let r' = Record.delete (Proxy @tag) r ∷ Record rf
-    pure (Constructor (Argument r'))
+    pure (Constructor (Argument r))
 
 instance gFlatCasesSum ∷
   ( GFlatCases tag r1 (Constructor name lhs)

test/Test/Sum.purs

@@ -7,10 +7,11 @@ import Data.Argonaut.Core (stringify, stringifyWithIndent)
 import Data.Argonaut.Decode (parseJson)
 import Data.Bifunctor (lmap)
 import Data.Codec (decode, encode)
-import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..))
 import Data.Codec.Argonaut as C
 import Data.Codec.Argonaut.Record as CR
-import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlat, sumFlatWith, sumWith)
+import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlatWith, sumWith)
+import Data.Either (Either(..))
 import Data.Generic.Rep (class Generic)
 import Data.Show.Generic (genericShow)
 import Data.String as Str
@@ -22,7 +23,6 @@ import Test.QuickCheck (class Arbitrary, arbitrary, quickCheck)
 import Test.QuickCheck.Arbitrary (genericArbitrary)
 import Test.Util (propCodec)
 import Type.Prelude (Proxy(..))
-import Type.Proxy (Proxy)
 
 --------------------------------------------------------------------------------
 
@@ -91,11 +91,20 @@ check codec val expectEncoded = do
 
   json ← liftEither $ lmap (show >>> error) $ parseJson encodedStr
 
-  decoded ← liftEither $ lmap (\err -> error ("decode failed: " <> show err <> " JSON was: " <> stringify json)) $ decode codec json
+  decoded ← liftEither $ lmap (\err → error ("decode failed: " <> show err <> " JSON was: " <> stringify json)) $ decode codec json
 
   when (decoded /= val) $
     throw ("decode check failed, expected: " <> show val <> ", got: " <> show decoded)
 
+checkFailure ∷ ∀ a. Show a ⇒ Eq a ⇒ JsonCodec a → JsonDecodeError → String → Effect Unit
+checkFailure codec err encodedStr = do
+  json ← liftEither $ lmap (show >>> error) $ parseJson encodedStr
+
+  let result = decode codec json
+
+  when (result /= Left err) $
+    throw ("decode check failed, expected: " <> show err <> ", got: " <> show result)
+
 main ∷ Effect Unit
 main = do
   log "Check sum"
@@ -184,6 +193,27 @@ main = do
             , "}"
             ]
 
+      checkFailure
+        (codecSample opts)
+        (Named "Sample" (TypeMismatch "Expecting at least one element"))
+        $ Str.joinWith "\n"
+            [ "{"
+            , "  \"customTag\": \"Baz\","
+            , "  \"customValues\": ["
+            , "    true"
+            , "  ]"
+            , "}"
+            ]
+
+      checkFailure
+        (codecSample opts)
+        (Named "Sample" (TypeMismatch "No case matched"))
+        $ Str.joinWith "\n"
+            [ "{"
+            , "  \"customTag\": \"Qux\""
+            , "}"
+            ]
+
     log "    - Option: Omit empty arguments"
     do
       let
@@ -315,6 +345,26 @@ main = do
             , "}"
             ]
 
+      checkFailure
+        (codecSample opts)
+        (Named "Sample" (TypeMismatch "Expecting at least one element"))
+        $ Str.joinWith "\n"
+            [ "{"
+            , "  \"Baz\": ["
+            , "    true"
+            , "  ]"
+            , "}"
+            ]
+
+      checkFailure
+        (codecSample opts)
+        (Named "Sample" (TypeMismatch "No case matched"))
+        $ Str.joinWith "\n"
+            [ "{"
+            , "  \"Qux\": []"
+            , "}"
+            ]
+
     log "    - Option: Unwrap single arguments"
     do
       let
@@ -385,5 +435,24 @@ main = do
           , "}"
           ]
 
+    checkFailure
+      codecSampleFlat
+      (Named "Sample" (Named "case FlatBaz" (AtKey "pos" MissingValue)))
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"FlatBaz\","
+          , "  \"active\": true"
+          , "}"
+          ]
+
+    checkFailure
+      codecSampleFlat
+      (Named "Sample" (TypeMismatch "No case matched"))
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"FlatQux\""
+          , "}"
+          ]
+
     quickCheck (propCodec arbitrary codecSampleFlat)