Merge pull request #2 from garyb/records

Add fancy record codecs

Author: garyb

src/Data/Codec/Argonaut.purs

@@ -18,13 +18,15 @@ module Data.Codec.Argonaut
   , JPropCodec
   , object
   , prop
+  , record
+  , recordProp
   , module Exports
   ) where
 
 import Prelude
 
 import Control.Monad.Reader (ReaderT(..), runReaderT)
-import Control.Monad.Writer (writer, mapWriter)
+import Control.Monad.Writer (Writer, writer, mapWriter)
 import Data.Argonaut.Core as J
 import Data.Array as A
 import Data.Bifunctor as BF
@@ -34,13 +36,17 @@ import Data.Either (Either(..))
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.Int as I
+import Data.List ((:))
 import Data.List as L
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), maybe, fromJust)
 import Data.Profunctor.Star (Star(..))
 import Data.String as S
 import Data.StrMap as SM
+import Data.Symbol (class IsSymbol, SProxy, reflectSymbol)
 import Data.Traversable (traverse)
 import Data.Tuple (Tuple(..))
+import Partial.Unsafe (unsafePartial)
+import Unsafe.Coerce (unsafeCoerce)
 
 -- | Codec type for `Json` values.
 type JsonCodec a = BasicCodec (Either JsonDecodeError) J.Json a
@@ -175,8 +181,55 @@ prop key codec = GCodec dec enc
     BF.lmap (AtKey key) case SM.lookup key obj of
       Just val → decode codec val
       Nothing → Left MissingValue
+  enc ∷ Star (Writer (L.List J.JAssoc)) a a
   enc = Star \val → writer $ Tuple val (pure (Tuple key (encode codec val)))
 
+-- | The starting value for a object-record codec. Used with `recordProp` it
+-- | provides a convenient method for defining codecs for record types that
+-- | encode into JSON objects of the same shape.
+-- |
+-- | For example:
+-- | ```
+-- | myRecordCodec =
+-- |   object "MyRecord" $ record
+-- |     # recordProp (SProxy :: SProxy "tag") tagCodec
+-- |     # recordProp (SProxy :: SProxy "value") valueCodec
+-- | ```
+record ∷ JPropCodec {}
+record = GCodec (pure {}) (Star \val → writer (Tuple val L.Nil))
+
+-- | Used with `record` to define codecs for record types that encode into JSON
+-- | objects of the same shape. See the comment on `record` for an example.
+recordProp
+  ∷ ∀ p a r r'
+  . IsSymbol p
+  ⇒ RowCons p a r r'
+  ⇒ SProxy p
+  → JsonCodec a
+  → JPropCodec (Record r)
+  → JPropCodec (Record r')
+recordProp p codecA codecR =
+  let key = reflectSymbol p in GCodec (dec' key) (enc' key)
+  where
+    dec' ∷ String → ReaderT J.JObject (Either JsonDecodeError) (Record r')
+    dec' key = ReaderT \obj → do
+      r ← decode codecR obj
+      a ← BF.lmap (AtKey key) case SM.lookup key obj of
+        Just val → decode codecA val
+        Nothing → Left MissingValue
+      pure $ unsafeSet key a r
+    enc' ∷ String → Star (Writer (L.List J.JAssoc)) (Record r') (Record r')
+    enc' key = Star \val →
+      writer $ Tuple val
+        $ Tuple key (encode codecA (unsafeGet key val))
+        : encode codecR (unsafeForget val)
+    unsafeForget ∷ Record r' → Record r
+    unsafeForget = unsafeCoerce
+    unsafeSet ∷ String → a → Record r → Record r'
+    unsafeSet key a = unsafeCoerce <<< SM.insert key a <<< unsafeCoerce
+    unsafeGet ∷ String → Record r' → a
+    unsafeGet s = unsafePartial fromJust <<< SM.lookup s <<< unsafeCoerce
+
 jsonPrimCodec
   ∷ ∀ a
    . String

src/Data/Codec/Argonaut/Common.purs

@@ -9,7 +9,7 @@ import Data.Argonaut.Core as J
 import Data.Array as A
 import Data.Bifunctor as BF
 import Data.Codec (basicCodec)
-import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, string, (<~<), (~))
+import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, string, (<~<), (~))
 import Data.Codec.Argonaut.Sum (Tag(..), taggedSum)
 import Data.Either (Either(..))
 import Data.List as L

src/Data/Codec/Argonaut/Compat.purs

@@ -10,7 +10,7 @@ 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, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, string, (<~<), (~))
+import Data.Codec.Argonaut (JIndexedCodec, JPropCodec, JsonCodec, JsonDecodeError(..), array, boolean, char, decode, encode, index, indexedArray, int, jarray, jobject, json, null, number, object, printJsonDecodeError, prop, record, recordProp, 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

@@ -7,12 +7,14 @@ import Control.Monad.Gen as Gen
 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.String.Gen (genAsciiString)
 import Data.StrMap.Gen (genStrMap)
+import Data.Symbol (SProxy(..))
 import Test.QuickCheck (QC, Result, quickCheck)
 import Test.QuickCheck.Gen (Gen)
-import Test.Util (propCodec)
+import Test.Util (propCodec, propCodec', genInt)
 
 main :: QC () Unit
 main = do
@@ -40,6 +42,12 @@ main = do
   log "Checking JObject codec"
   quickCheck propJObject
 
+  log "Checking object codec"
+  quickCheck (propTestRecord codecObject)
+
+  log "Checking record codec"
+  quickCheck (propTestRecord codecRecord)
+
 propNull ∷ Gen Result
 propNull = propCodec (pure J.jNull) JA.null
 
@@ -50,7 +58,7 @@ propNumber ∷ Gen Result
 propNumber = propCodec (Gen.chooseFloat (-100000.0) 100000.0) JA.number
 
 propInt ∷ Gen Result
-propInt = propCodec (Gen.chooseInt (-100000) 100000) JA.int
+propInt = propCodec genInt JA.int
 
 propString ∷ Gen Result
 propString = propCodec genAsciiString JA.string
@@ -63,3 +71,34 @@ propJArray = propCodec (Gen.unfoldable genJson) JA.jarray
 
 propJObject ∷ Gen Result
 propJObject = propCodec (genStrMap genAsciiString genJson) JA.jobject
+
+type TestRecord = { tag ∷ String, x ∷ Int, y ∷ Boolean }
+
+genRecord ∷ Gen TestRecord
+genRecord =
+  { tag: _, x: _, y: _ }
+    <$> genAsciiString
+    <*> genInt
+    <*> Gen.chooseBool
+
+codecObject ∷ JA.JsonCodec TestRecord
+codecObject =
+  JA.object "Test Object" $
+    { tag: _, x: _, y: _ }
+      <$> _.tag ~ JA.prop "tag" JA.string
+      <*> _.x ~ JA.prop "x" JA.int
+      <*> _.y ~ JA.prop "y" JA.boolean
+
+codecRecord ∷ JA.JsonCodec TestRecord
+codecRecord =
+  JA.object "Test Record" $ JA.record
+    # JA.recordProp (SProxy ∷ SProxy "tag") JA.string
+    # JA.recordProp (SProxy ∷ SProxy "x") JA.int
+    # JA.recordProp (SProxy ∷ SProxy "y") JA.boolean
+
+propTestRecord ∷ JA.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 <> " }"

test/Test/Util.purs

@@ -5,13 +5,21 @@ import Prelude
 import Control.Monad.Gen as Gen
 import Data.Codec.Argonaut.Common as JA
 import Data.Either (Either(..))
-import Test.QuickCheck (Result, (===))
+import Test.QuickCheck (Result(..), (<?>))
 import Test.QuickCheck.Gen (Gen)
 
-propCodec ∷ ∀ a. Eq a ⇒ Show a ⇒ Gen a → JA.JsonCodec a → Gen Result
-propCodec gen codec = do
+propCodec' ∷ ∀ a. (a → a → Boolean) → (a → String) → Gen a → JA.JsonCodec a → Gen Result
+propCodec' eq' show' gen codec = do
   x ← gen
-  pure $ Right x === JA.decode codec (JA.encode codec x)
+  pure case JA.decode codec (JA.encode codec x) of
+    Left err →
+      Failed
+        $ "Decoding " <> show' x <> " failed with error: " <> JA.printJsonDecodeError err
+    Right y →
+      x `eq'` y <?> "Decoded result:\n" <> show' x <> "\n\nDid not match input:\n" <> show' y
+
+propCodec ∷ ∀ a. Eq a ⇒ Show a ⇒ Gen a → JA.JsonCodec a → Gen Result
+propCodec = propCodec' eq show
 
 genInt ∷ Gen Int
 genInt = Gen.chooseInt (-100000) 100000