Merge pull request #8 from natefaubion/variant-codec

Variant codec from record of codecs

Author: garyb

bower.json

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

src/Data/Codec/Argonaut/Variant.purs

@@ -10,11 +10,14 @@ import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..), decode, encode, jobj
 import Data.Either (Either(..))
 import Data.Newtype (un)
 import Data.Profunctor.Star (Star(..))
+import Data.Record as Rec
 import Data.StrMap as SM
 import Data.StrMap.ST as SMST
-import Data.Symbol (class IsSymbol, reflectSymbol)
+import Data.Symbol (class IsSymbol, reflectSymbol, SProxy(..))
 import Data.Tuple (Tuple(..))
 import Data.Variant (SProxy, Variant, case_, inj, on)
+import Type.Equality as TE
+import Type.Row as R
 import Unsafe.Coerce (unsafeCoerce)
 
 variant ∷ JsonCodec (Variant ())
@@ -57,3 +60,33 @@ variantCase proxy eacodec (GCodec dec enc) = GCodec dec' enc'
 
   coerceR ∷ Variant r → Variant r'
   coerceR = unsafeCoerce
+
+class VariantCodec (rl ∷ R.RowList) (ri ∷ # Type) (ro ∷ # Type) | rl → ri ro where
+  variantCodec ∷ R.RLProxy rl → Record ri → JsonCodec (Variant ro)
+
+instance variantCodecNil ∷ VariantCodec R.Nil () () where
+  variantCodec _ _ = variant
+
+instance variantCodecCons ∷
+  ( VariantCodec rs ri' ro'
+  , RowCons sym (Either a (JsonCodec a)) ri' ri
+  , RowCons sym a ro' ro
+  , IsSymbol sym
+  , TE.TypeEquals co (Either a (JsonCodec a))
+  ) ⇒ VariantCodec (R.Cons sym co rs) ri ro where
+  variantCodec _ codecs =
+    variantCase (SProxy ∷ SProxy sym) codec tail
+    where
+    codec ∷ Either a (JsonCodec a)
+    codec = TE.from (Rec.get (SProxy ∷ SProxy sym) codecs)
+
+    tail ∷ JsonCodec (Variant ro')
+    tail = variantCodec (R.RLProxy ∷ R.RLProxy rs) ((unsafeCoerce ∷ Record ri → Record ri') codecs)
+
+variantMatch
+  ∷ ∀ rl ri ro
+  . R.RowToList ri rl
+  ⇒ VariantCodec rl ri ro
+  ⇒ Record ri
+  → JsonCodec (Variant ro)
+variantMatch = variantCodec (R.RLProxy ∷ R.RLProxy rl)

test/Test/Variant.purs

@@ -3,6 +3,7 @@ module Test.Variant where
 import Prelude
 
 import Control.Monad.Eff.Console (log)
+import Control.Monad.Gen (chooseBool, chooseInt)
 import Control.Monad.Gen.Common as GenC
 import Data.Codec.Argonaut.Common as JA
 import Data.Codec.Argonaut.Variant as JAV
@@ -13,8 +14,15 @@ import Data.String.Gen (genAsciiString)
 import Data.Symbol (SProxy(..))
 import Data.Variant as V
 import Test.QuickCheck (QC, quickCheck)
+import Test.QuickCheck.Gen (Gen)
 import Test.Util (genInt, propCodec)
 
+type TestVariant = V.Variant
+  ( a ∷ Int
+  , b ∷ String
+  , c ∷ Maybe Boolean
+  )
+
 main :: QC () Unit
 main = do
   log "Checking Maybe-variant codec"
@@ -29,6 +37,10 @@ main = do
       (GenC.genEither genAsciiString genInt)
       (codecEither JA.string JA.int)
 
+  log "Checking variant codec"
+  quickCheck $
+    propCodec genVariant codecVariant
+
 codecMaybe ∷ ∀ a. JA.JsonCodec a → JA.JsonCodec (Maybe a)
 codecMaybe codecA =
   dimap toVariant fromVariant
@@ -60,3 +72,18 @@ codecEither codecA codecB =
     # V.on _Right Right
   _Left = SProxy ∷ SProxy "left"
   _Right = SProxy ∷ SProxy "right"
+
+genVariant ∷ Gen TestVariant
+genVariant = do
+  tag ← chooseInt 1 3
+  case tag of
+    1 → V.inj (SProxy ∷ SProxy "a") <$> genInt
+    2 → V.inj (SProxy ∷ SProxy "b") <$> genAsciiString
+    _ → V.inj (SProxy ∷ SProxy "c") <$> GenC.genMaybe chooseBool
+
+codecVariant ∷ JA.JsonCodec TestVariant
+codecVariant = JAV.variantMatch
+  { a: Right JA.int
+  , b: Right JA.string
+  , c: Right (JA.maybe JA.boolean)
+  }