Record codec from record of codecs

Author: natefaubion

bower.json

@@ -19,7 +19,10 @@
     "purescript-argonaut-core": "^3.1.0",
     "purescript-codec": "^2.0.0",
     "purescript-generics-rep": "^5.1.0",
-    "purescript-variant": "^1.1.0"
+    "purescript-variant": "^1.1.0",
+    "purescript-typelevel-prelude": "^2.4.0",
+    "purescript-record": "^0.2.0",
+    "purescript-type-equality": "^2.1.0"
   },
   "devDependencies": {
     "purescript-argonaut-codecs": "^3.1.0",

src/Data/Codec/Argonaut/Record.purs

@@ -0,0 +1,43 @@
+module Data.Codec.Argonaut.Record
+  ( class RowListCodec
+  , rowListCodec
+  , record
+  ) where
+
+import Data.Codec.Argonaut as CA
+import Data.Record as Rec
+import Data.Symbol (class IsSymbol, SProxy(..))
+import Type.Equality as TE
+import Type.Row as R
+import Unsafe.Coerce (unsafeCoerce)
+
+class RowListCodec (rl ∷ R.RowList) (ri ∷ # Type) (ro ∷ # Type) | rl → ri ro where
+  rowListCodec ∷ R.RLProxy rl → Record ri → CA.JPropCodec (Record ro)
+
+instance rowListCodecNil ∷ RowListCodec R.Nil () () where
+  rowListCodec _ _ = CA.record
+
+instance rowListCodecCons ∷
+  ( RowListCodec rs ri' ro'
+  , RowCons sym (CA.JsonCodec a) ri' ri
+  , RowCons sym a ro' ro
+  , IsSymbol sym
+  , TE.TypeEquals co (CA.JsonCodec a)
+  ) ⇒ RowListCodec (R.Cons sym co rs) ri ro where
+  rowListCodec _ codecs =
+    CA.recordProp (SProxy ∷ SProxy sym) codec tail
+    where
+    codec ∷ CA.JsonCodec a
+    codec = TE.from (Rec.get (SProxy ∷ SProxy sym) codecs)
+
+    tail ∷ CA.JPropCodec (Record ro')
+    tail = rowListCodec (R.RLProxy ∷ R.RLProxy rs) ((unsafeCoerce ∷ Record ri → Record ri') codecs)
+
+-- | Constructs a record codec from a record of codecs.
+record
+  ∷ ∀ ri ro rl
+  . R.RowToList ri rl
+  ⇒ RowListCodec rl ri ro
+  ⇒ Record ri
+  → CA.JPropCodec (Record ro)
+record = rowListCodec (R.RLProxy ∷ R.RLProxy rl)

test/Test/Main.purs

@@ -9,6 +9,7 @@ import Test.Migration as Migration
 import Test.Prim as Prim
 import Test.QuickCheck (QC)
 import Test.Variant as Variant
+import Test.Record as Record
 
 main :: QC () Unit
 main = do
@@ -28,6 +29,10 @@ main = do
   log "------------------------------------------------------------"
   Variant.main
   log ""
+  log "Checking Record codecs"
+  log "------------------------------------------------------------"
+  Record.main
+  log ""
   log "Checking Migration codecs"
   log "------------------------------------------------------------"
   Migration.main

test/Test/Record.purs

@@ -0,0 +1,76 @@
+module Test.Record where
+
+import Prelude
+
+import Control.Monad.Eff.Console (log)
+import Control.Monad.Gen as Gen
+import Control.Monad.Gen.Common as GenC
+import Data.Codec.Argonaut.Common as JA
+import Data.Codec.Argonaut.Record as JAR
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype, unwrap, wrap)
+import Data.Profunctor (dimap)
+import Data.String.Gen (genAsciiString)
+import Test.QuickCheck (QC, quickCheck)
+import Test.QuickCheck.Gen (Gen)
+import Test.Util (genInt, propCodec)
+
+type OuterR =
+  { a ∷ Int
+  , b ∷ String
+  , c ∷ Maybe InnerR
+  }
+
+type InnerR =
+  { n ∷ Int
+  , m ∷ Boolean
+  }
+
+newtype Outer = Outer OuterR
+
+derive instance newtypeOuter ∷ Newtype Outer _
+
+instance showOuter ∷ Show Outer where
+  show (Outer r) = "Outer " <> show (JA.encode outerCodec r)
+
+instance eqOuter ∷ Eq Outer where
+  eq (Outer o1) (Outer o2) =
+    o1.a == o2.a
+    && o1.b == o2.b
+    && case o1.c, o2.c of
+        Nothing, Nothing → true
+        Just i1, Just i2 → i1.n == i2.n && i1.m == i2.m
+        _, _ → false
+
+outerCodec ∷ JA.JsonCodec OuterR
+outerCodec =
+  JA.object "Outer" $ JAR.record
+    { a: JA.int
+    , b: JA.string
+    , c: JA.maybe innerCodec
+    }
+
+innerCodec ∷ JA.JsonCodec InnerR
+innerCodec =
+  JA.object "Inner" $ JAR.record
+    { n: JA.int
+    , m: JA.boolean
+    }
+
+genOuter ∷ Gen OuterR
+genOuter = do
+  a ← genInt
+  b ← genAsciiString
+  c ← GenC.genMaybe genInner
+  pure { a, b, c }
+
+genInner ∷ Gen InnerR
+genInner = do
+  n ← genInt
+  m ← Gen.chooseBool
+  pure { n, m }
+
+main ∷ QC () Unit
+main = do
+  log "Checking record codec"
+  quickCheck $ propCodec (Outer <$> genOuter) (dimap unwrap wrap outerCodec)