Add optional property combinator

Author: garyb

src/Data/Codec/Argonaut.purs

@@ -22,6 +22,7 @@ module Data.Codec.Argonaut
   , prop
   , record
   , recordProp
+  , recordPropOptional
   , fix
   , prismaticCodec
   , module Exports
@@ -33,6 +34,7 @@ import Control.Monad.Reader (ReaderT(..), runReaderT)
 import Control.Monad.Writer (Writer, writer, mapWriter)
 import Data.Argonaut.Core as J
 import Data.Array as A
+import Data.Bifunctor (lmap)
 import Data.Bifunctor as BF
 import Data.Codec (BasicCodec, Codec, GCodec(..), basicCodec, bihoistGCodec, decode, encode)
 import Data.Codec (decode, encode, (~), (<~<), (>~>)) as Exports
@@ -282,6 +284,44 @@ recordProp p codecA codecR =
     unsafeSet key a = unsafeCoerce <<< FO.insert key a <<< unsafeCoerce
     unsafeGet ∷ String → Record r' → a
     unsafeGet s = unsafePartial fromJust <<< FO.lookup s <<< unsafeCoerce
+    
+-- | Used with `record` to define an optional field.
+-- |
+-- | This will only decode the property as `Nothing` if the field does not exist
+-- | in the object - having a values such as `null` assigned will need handling 
+-- | separately.
+-- |
+-- | The property will be omitted when encoding and the value is `Nothing`.
+recordPropOptional
+  ∷ ∀ p a r r'
+  . IsSymbol p
+  ⇒ Row.Cons p (Maybe a) r r'
+  ⇒ Proxy p
+  → JsonCodec a
+  → JPropCodec (Record r)
+  → JPropCodec (Record r')
+recordPropOptional p codecA codecR =
+  let key = reflectSymbol p in GCodec (dec' key) (enc' key)
+  where
+    dec' ∷ String → ReaderT (FO.Object J.Json) (Either JsonDecodeError) (Record r')
+    dec' key = ReaderT \obj → do
+      r ← decode codecR obj
+      a ← lmap (AtKey key) case FO.lookup key obj of
+        Just val → Just <$> decode codecA val
+        _ → Right Nothing
+      pure $ unsafeSet key a r
+    enc' ∷ String → Star (Writer (L.List (Tuple String J.Json))) (Record r') (Record r')
+    enc' key = Star \val → do
+      let w = encode codecR (unsafeForget val)
+      writer $ Tuple val case unsafeGet key val of
+        Just a → Tuple key (encode codecA a) : w
+        Nothing → w
+    unsafeForget ∷ Record r' → Record r
+    unsafeForget = unsafeCoerce
+    unsafeSet ∷ String → Maybe a → Record r → Record r'
+    unsafeSet key a = unsafeCoerce <<< FO.insert key a <<< unsafeCoerce
+    unsafeGet ∷ String → Record r' → Maybe a
+    unsafeGet s = unsafePartial fromJust <<< FO.lookup s <<< unsafeCoerce
 
 jsonPrimCodec
   ∷ ∀ a

src/Data/Codec/Argonaut/Common.purs

@@ -6,7 +6,7 @@ module Data.Codec.Argonaut.Common
 import Prelude hiding (map)
 
 import Data.Array as A
-import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, fix, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, string, (<~<), (~))
+import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, fix, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, recordPropOptional, string, (<~<), (~))
 import Data.Codec.Argonaut.Sum (taggedSum)
 import Data.Either (Either(..))
 import Data.Functor as F

src/Data/Codec/Argonaut/Compat.purs

@@ -2,15 +2,15 @@
 module Data.Codec.Argonaut.Compat
   ( module Data.Codec.Argonaut.Compat
   , module Data.Codec.Argonaut
-  , module Common
+  , module Common 
   ) where
 
 import Prelude
 
 import Data.Argonaut.Core as J
 import Data.Bifunctor as BF
 import Data.Codec (basicCodec, mapCodec)
-import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, fix, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, string, (<~<), (~))
+import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, fix, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, recordPropOptional, string, (<~<), (~))
 import Data.Codec.Argonaut.Common (either, list, map, tuple) as Common
 import Data.Either (Either)
 import Data.Functor as F

test/Test/Prim.purs

@@ -8,17 +8,21 @@ import Data.Argonaut.Core as J
 import Data.Argonaut.Gen (genJson)
 import Data.Char.Gen (genAsciiChar)
 import Data.Codec.Argonaut.Common ((~))
-import Data.Codec.Argonaut.Common as JA
+import Data.Codec.Argonaut.Common as CA
+import Data.Either (Either(..), either, note)
 import Data.Generic.Rep (class Generic)
 import Data.Maybe (Maybe(..))
+import Data.Int as Int
+import Data.Maybe (Maybe(..), maybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.Profunctor (dimap)
 import Data.Show.Generic (genericShow)
 import Data.String.Gen (genAsciiString)
 import Effect (Effect)
 import Effect.Console (log)
+import Foreign.Object as Object
 import Foreign.Object.Gen (genForeignObject)
-import Test.QuickCheck (Result, quickCheck)
+import Test.QuickCheck (Result(..), quickCheck)
 import Test.QuickCheck.Gen (Gen)
 import Test.Util (genInt, propCodec, propCodec', propCodec'')
 import Type.Proxy (Proxy(..))
@@ -43,8 +47,8 @@ main = do
   log "Checking Char codec"
   quickCheck propChar
 
-  log "Checking JArray codec"
-  quickCheck propJArray
+  log "Checking CArray codec"
+  quickCheck propCArray
 
   log "Checking JObject codec"
   quickCheck propJObject
@@ -55,32 +59,41 @@ main = do
   log "Checking record codec"
   quickCheck (propTestRecord codecRecord)
 
+  log "Checking record codec with optional field"
+  quickCheck propTestRecordOptional
+  
+  log "Checking record codec with optional field does include the field"
+  quickCheck propPresentOptionalField
+  
+  log "Checking record codec with optional field does omit the field entirely"
+  quickCheck propMissingOptionalField
+
   log "Checking fixed-point codec"
   quickCheck propFix
 
 propNull ∷ Gen Result
-propNull = propCodec (pure unit) JA.null
+propNull = propCodec (pure unit) CA.null
 
 propBoolean ∷ Gen Result
-propBoolean = propCodec Gen.chooseBool JA.boolean
+propBoolean = propCodec Gen.chooseBool CA.boolean
 
 propNumber ∷ Gen Result
-propNumber = propCodec (Gen.chooseFloat (-100000.0) 100000.0) JA.number
+propNumber = propCodec (Gen.chooseFloat (-100000.0) 100000.0) CA.number
 
 propInt ∷ Gen Result
-propInt = propCodec genInt JA.int
+propInt = propCodec genInt CA.int
 
 propString ∷ Gen Result
-propString = propCodec genAsciiString JA.string
+propString = propCodec genAsciiString CA.string
 
 propChar ∷ Gen Result
-propChar = propCodec genAsciiChar JA.char
+propChar = propCodec genAsciiChar CA.char
 
-propJArray ∷ Gen Result
-propJArray = propCodec'' (show <<< map J.stringify) (Gen.unfoldable genJson) JA.jarray
+propCArray ∷ Gen Result
+propCArray = propCodec'' (show <<< map J.stringify) (Gen.unfoldable genJson) CA.jarray
 
 propJObject ∷ Gen Result
-propJObject = propCodec'' (show <<< map J.stringify) (genForeignObject genAsciiString genJson) JA.jobject
+propJObject = propCodec'' (show <<< map J.stringify) (genForeignObject genAsciiString genJson) CA.jobject
 
 type TestRecord = { tag ∷ String, x ∷ Int, y ∷ Boolean }
 
@@ -91,27 +104,73 @@ genRecord =
     <*> genInt
     <*> Gen.chooseBool
 
-codecObject ∷ JA.JsonCodec TestRecord
+codecObject ∷ CA.JsonCodec TestRecord
 codecObject =
-  JA.object "Test Object" $
+  CA.object "Test Object" $
     { tag: _, x: _, y: _ }
-      <$> _.tag ~ JA.prop "tag" JA.string
-      <*> _.x ~ JA.prop "x" JA.int
-      <*> _.y ~ JA.prop "y" JA.boolean
+      <$> _.tag ~ CA.prop "tag" CA.string
+      <*> _.x ~ CA.prop "x" CA.int
+      <*> _.y ~ CA.prop "y" CA.boolean
 
-codecRecord ∷ JA.JsonCodec TestRecord
+codecRecord ∷ CA.JsonCodec TestRecord
 codecRecord =
-  JA.object "Test Record" $ JA.record
-    # JA.recordProp (Proxy ∷ Proxy "tag") JA.string
-    # JA.recordProp (Proxy ∷ Proxy "x") JA.int
-    # JA.recordProp (Proxy ∷ Proxy "y") JA.boolean
-
-propTestRecord ∷ JA.JsonCodec TestRecord → Gen Result
+  CA.object "Test Record" $ CA.record
+    # CA.recordProp (Proxy ∷ Proxy "tag") CA.string
+    # CA.recordProp (Proxy ∷ Proxy "x") CA.int
+    # CA.recordProp (Proxy ∷ Proxy "y") CA.boolean
+    
+propTestRecord ∷ CA.JsonCodec TestRecord → Gen Result
 propTestRecord = propCodec' checkEq print genRecord
   where
   checkEq r1 r2 = r1.tag == r2.tag && r1.x == r2.x && r1.y == r2.y
   print { tag, x, y } =
     "{ tag: " <> show tag <> ", x: " <> show x <> ", y: " <> show y <> " }"
+    
+type TestRecordOptional = { tag ∷ String, x ∷ Maybe Int }
+
+genRecordOptional ∷ Gen TestRecordOptional
+genRecordOptional =
+  { tag: _, x: _ }
+    <$> genAsciiString
+    <*> GenC.genMaybe genInt
+
+codecRecordOptional ∷ CA.JsonCodec TestRecordOptional
+codecRecordOptional =
+  CA.object "Test record with optional field" $ CA.record
+    # CA.recordProp (Proxy ∷ Proxy "tag") CA.string
+    # CA.recordPropOptional (Proxy ∷ Proxy "x") CA.int
+
+propTestRecordOptional ∷ Gen Result
+propTestRecordOptional = propCodec' checkEq print genRecordOptional codecRecordOptional
+  where
+  checkEq r1 r2 = r1.tag == r2.tag && r1.x == r2.x
+  print { tag, x } =
+    case x of 
+      Just x' → "{ tag: " <> show tag <> ", x: " <> show x <> " }"
+      Nothing → "{ tag: " <> show tag <> " }"
+      
+propPresentOptionalField ∷ Gen Result
+propPresentOptionalField = do
+  tag ← genAsciiString
+  x ← genInt
+  let value = { tag, x: Just x }
+  let json = CA.encode codecRecordOptional value
+  pure $ either Failed (pure Success) do
+    obj ← note "Encoded JSON is not an object" $ J.toObject json
+    prop ← note "Optional property unexpectedly missing in object" $ Object.lookup "x" obj
+    n ← note "x value is not a plain number" $ J.toNumber prop
+    if n == Int.toNumber x
+      then pure unit 
+      else Left "x value is wrong"
+      
+propMissingOptionalField ∷ Gen Result
+propMissingOptionalField = do
+  tag ← genAsciiString
+  let value = { tag, x: Nothing }
+  let json = CA.encode codecRecordOptional value
+  pure $ either Failed (pure Success) do
+    obj ← note "Encoded JSON is not an object" $ J.toObject json
+    maybe (Right Success) (\_ → Left "Optional property unexpectedly appeared in object") $ Object.lookup "x" obj
 
 newtype FixTest = FixTest (Maybe FixTest)
 
@@ -126,9 +185,9 @@ genFixTest = Gen.sized \n →
   then pure $ FixTest Nothing
   else FixTest <$> Gen.resize (_ - 1) (GenC.genMaybe genFixTest)
 
-codecFixTest ∷ JA.JsonCodec FixTest
-codecFixTest = JA.fix \codec →
-  dimap unwrap wrap (JA.maybe codec)
+codecFixTest ∷ CA.JsonCodec FixTest
+codecFixTest = CA.fix \codec →
+  dimap unwrap wrap (CA.maybe codec)
 
 propFix ∷ Gen Result
 propFix = propCodec genFixTest codecFixTest