Merge pull request #65 from m-bock/sum-flat

garyb · web-flow · commit 368fc254cd1d · 2024-11-26T15:44:58.000Z
`sumFlat` - Encodes sum types with single record fields in one object
diff --git a/package.json b/package.json
@@ -9,7 +9,7 @@
     "pulp": "^16.0.0",
     "purescript": "^0.15.0",
     "purescript-psa": "^0.8.2",
-    "purs-tidy": "^0.9.2",
+    "purs-tidy": "^0.11.0",
     "rimraf": "^3.0.0"
   }
 }
diff --git a/src/Data/Codec/Argonaut/Sum.purs b/src/Data/Codec/Argonaut/Sum.purs
@@ -1,17 +1,25 @@
 module Data.Codec.Argonaut.Sum
   ( Encoding(..)
+  , FlatEncoding
   , class GCases
   , class GFields
+  , class GFlatCases
   , defaultEncoding
+  , defaultFlatEncoding
   , enumSum
   , gCasesDecode
   , gCasesEncode
   , gFieldsDecode
   , gFieldsEncode
+  , gFlatCasesDecode
+  , gFlatCasesEncode
   , sum
+  , sumFlat
+  , sumFlatWith
   , sumWith
   , taggedSum
-  ) where
+  )
+  where
 
 import Prelude
 
@@ -23,8 +31,9 @@ import Data.Array as Array
 import Data.Bifunctor (lmap)
 import Data.Codec (codec', encode)
 import Data.Codec as Codec
-import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..), jobject)
+import Data.Codec.Argonaut (JPropCodec, JsonCodec, JsonDecodeError(..), jobject)
 import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
 import Data.Either (Either(..), note)
 import Data.Generic.Rep (class Generic, Argument(..), Constructor(..), NoArguments(..), Product(..), Sum(..), from, to)
 import Data.Maybe (Maybe(..), maybe)
@@ -206,8 +215,8 @@ else instance gCasesConstructorManyArgs ∷
 instance gCasesSum ∷
   ( GCases r1 (Constructor name lhs)
   , GCases r2 rhs
-  , Row.Cons name codecs1 () r1
-  , Row.Cons name codecs1 r2 r
+  , Row.Cons name codec () r1
+  , Row.Cons name codec r2 r
   , Row.Union r1 r2 r
   , Row.Lacks name r2
   , IsSymbol name
@@ -216,8 +225,8 @@ instance gCasesSum ∷
   gCasesEncode ∷ Encoding → Record r → Sum (Constructor name lhs) rhs → Json
   gCasesEncode encoding r =
     let
-      codecs1 = Record.get (Proxy @name) r ∷ codecs1
-      r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
+      codec = Record.get (Proxy @name) r ∷ codec
+      r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
       r2 = unsafeDelete (Proxy @name) r ∷ Record r2
     in
       case _ of
@@ -227,8 +236,8 @@ instance gCasesSum ∷
   gCasesDecode ∷ Encoding → Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
   gCasesDecode encoding r tagged = do
     let
-      codecs1 = Record.get (Proxy @name) r ∷ codecs1
-      r1 = Record.insert (Proxy @name) codecs1 {} ∷ Record r1
+      codec = Record.get (Proxy @name) r ∷ codec
+      r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
       r2 = Record.delete (Proxy @name) r ∷ Record r2
     let
       lhs = gCasesDecode encoding r1 tagged ∷ _ (Constructor name lhs)
@@ -393,7 +402,135 @@ encodeSumCase encoding tag jsons =
         encode jobject $ Obj.fromFoldable $ catMaybes
           [ tagEntry, valEntry ]
 
+type FlatEncoding (tag ∷ Symbol) =
+  { tag ∷ Proxy tag
+  }
+
+defaultFlatEncoding ∷ FlatEncoding "tag"
+defaultFlatEncoding = { tag: Proxy }
+
+sumFlat ∷ ∀ r rep a. GFlatCases "tag" r rep ⇒ Generic a rep ⇒ String → Record r → JsonCodec a
+sumFlat = sumFlatWith defaultFlatEncoding
+
+sumFlatWith ∷ ∀ @tag r rep a. GFlatCases tag r rep ⇒ Generic a rep ⇒ FlatEncoding tag -> String → Record r → JsonCodec a
+sumFlatWith _ name r =
+  dimap from to $ codec' dec enc
+  where
+  dec = gFlatCasesDecode @tag r >>> (lmap $ Named name)
+  enc = gFlatCasesEncode @tag r
+
+class GFlatCases ∷ Symbol → Row Type → Type → Constraint
+class
+  GFlatCases tag r rep
+  where
+  gFlatCasesEncode ∷ Record r → rep → Json
+  gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError rep
+
+instance gFlatCasesConstructorNoArg ∷
+  ( Row.Cons name Unit () rc
+  , Row.Cons tag String () rf
+  , IsSymbol name
+  , IsSymbol tag
+  ) ⇒
+  GFlatCases tag rc (Constructor name NoArguments) where
+  gFlatCasesEncode ∷ Record rc → Constructor name NoArguments → Json
+  gFlatCasesEncode _ (Constructor NoArguments) =
+    let
+      name = reflectSymbol (Proxy @name) ∷ 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)
+      rcWithTag = Record.insert (Proxy @tag) name {} ∷ Record rf
+    in
+      CA.encode codecWithTag rcWithTag
+
+  gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name NoArguments)
+  gFlatCasesDecode _ json = do
+    let
+      name = reflectSymbol (Proxy @name) ∷ 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 ← CA.decode codecWithTag json ∷ _ (Record rf)
+    let actualTag = Record.get (Proxy @tag) r ∷ String
+
+    when (actualTag /= name)
+      $ Left
+      $ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
+
+    pure (Constructor NoArguments)
+
+instance gFlatCasesConstructorSingleArg ∷
+  ( Row.Cons name (JPropCodec (Record rf)) () rc
+  , Row.Lacks tag rf
+  , Row.Cons tag String rf rf'
+  , IsSymbol name
+  , IsSymbol tag
+  ) ⇒
+  GFlatCases tag rc (Constructor name (Argument (Record rf))) where
+  gFlatCasesEncode ∷ Record rc → Constructor name (Argument (Record rf)) → Json
+  gFlatCasesEncode rc (Constructor (Argument rf)) =
+    let
+      name = reflectSymbol (Proxy @name) ∷ String
+      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')
+      rcWithTag = Record.insert (Proxy @tag) name rf ∷ Record rf'
+    in
+      CA.encode codecWithTag rcWithTag
+
+  gFlatCasesDecode ∷ Record rc → Json → Either JsonDecodeError (Constructor name (Argument (Record rf)))
+  gFlatCasesDecode rc json = do
+    let
+      name = reflectSymbol (Proxy @name) ∷ String
+      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 ← CA.decode codecWithTag json ∷ _ (Record rf')
+
+    let actualTag = Record.get (Proxy @tag) r ∷ String
+    when (actualTag /= name)
+      $ Left
+      $ TypeMismatch ("Expecting tag `" <> name <> "`, got `" <> actualTag <> "`")
+
+    let r' = Record.delete (Proxy @tag) r ∷ Record rf
+    pure (Constructor (Argument r'))
+
+instance gFlatCasesSum ∷
+  ( GFlatCases tag r1 (Constructor name lhs)
+  , GFlatCases tag r2 rhs
+  , Row.Cons name codec () r1
+  , Row.Cons name codec r2 r
+  , Row.Union r1 r2 r
+  , Row.Lacks name r2
+  , IsSymbol name
+  ) ⇒
+  GFlatCases tag r (Sum (Constructor name lhs) rhs) where
+  gFlatCasesEncode ∷ Record r → Sum (Constructor name lhs) rhs → Json
+  gFlatCasesEncode r =
+    let
+      codec = Record.get (Proxy @name) r ∷ codec
+      r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
+      r2 = unsafeDelete (Proxy @name) r ∷ Record r2
+    in
+      case _ of
+        Inl lhs → gFlatCasesEncode @tag r1 lhs
+        Inr rhs → gFlatCasesEncode @tag r2 rhs
+
+  gFlatCasesDecode ∷ Record r → Json → Either JsonDecodeError (Sum (Constructor name lhs) rhs)
+  gFlatCasesDecode r tagged = do
+    let
+      codec = Record.get (Proxy @name) r ∷ codec
+      r1 = Record.insert (Proxy @name) codec {} ∷ Record r1
+      r2 = Record.delete (Proxy @name) r ∷ Record r2
+    let
+      lhs = gFlatCasesDecode @tag r1 tagged ∷ _ (Constructor name lhs)
+      rhs = gFlatCasesDecode @tag r2 tagged ∷ _ rhs
+    (Inl <$> lhs) <|> (Inr <$> rhs)
+
 -- | Same as `Record.delete` but deleting only happens at the type level
 -- | and the value is left untouched.
 unsafeDelete ∷ ∀ r1 r2 l a. IsSymbol l ⇒ Row.Lacks l r1 ⇒ Row.Cons l a r1 r2 ⇒ Proxy l → Record r2 → Record r1
-unsafeDelete _ r = unsafeCoerce r
+unsafeDelete _ r = unsafeCoerce r
+
diff --git a/test/Test/Sum.purs b/test/Test/Sum.purs
@@ -9,18 +9,22 @@ import Data.Bifunctor (lmap)
 import Data.Codec (decode, encode)
 import Data.Codec.Argonaut (JsonCodec)
 import Data.Codec.Argonaut as C
-import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumWith)
+import Data.Codec.Argonaut.Record as CR
+import Data.Codec.Argonaut.Sum (Encoding(..), defaultEncoding, sumFlat, sumFlatWith, sumWith)
 import Data.Generic.Rep (class Generic)
 import Data.Show.Generic (genericShow)
 import Data.String as Str
 import Data.Tuple.Nested ((/\))
 import Effect (Effect)
 import Effect.Console (log)
 import Effect.Exception (error, throw)
-import Test.QuickCheck (quickCheck)
+import Test.QuickCheck (class Arbitrary, arbitrary, quickCheck)
 import Test.QuickCheck.Arbitrary (genericArbitrary)
-import Test.QuickCheck.Gen (Gen)
 import Test.Util (propCodec)
+import Type.Prelude (Proxy(..))
+import Type.Proxy (Proxy)
+
+--------------------------------------------------------------------------------
 
 data Sample
   = Foo
@@ -30,8 +34,8 @@ data Sample
 derive instance Generic Sample _
 derive instance Eq Sample
 
-genMySum ∷ Gen Sample
-genMySum = genericArbitrary
+instance Arbitrary Sample where
+  arbitrary = genericArbitrary
 
 instance Show Sample where
   show = genericShow
@@ -43,6 +47,42 @@ codecSample encoding = sumWith encoding "Sample"
   , "Baz": C.boolean /\ C.string /\ C.int
   }
 
+--------------------------------------------------------------------------------
+
+data SampleFlat
+  = FlatFoo
+  | FlatBar { errors ∷ Int }
+  | FlatBaz
+      { active ∷ Boolean
+      , name ∷ String
+      , pos ∷ { x ∷ Int, y ∷ Int }
+      }
+
+derive instance Generic SampleFlat _
+derive instance Eq SampleFlat
+
+instance Arbitrary SampleFlat where
+  arbitrary = genericArbitrary
+
+instance Show SampleFlat where
+  show = genericShow
+
+codecSampleFlat ∷ JsonCodec SampleFlat
+codecSampleFlat = sumFlatWith { tag: Proxy @"tag" } "Sample"
+  { "FlatFoo": unit
+  , "FlatBar": CR.record { errors: C.int }
+  , "FlatBaz": CR.record
+      { active: C.boolean
+      , name: C.string
+      , pos: CR.object "Pos"
+          { x: C.int
+          , y: C.int
+          }
+      }
+  }
+
+--------------------------------------------------------------------------------
+
 check ∷ ∀ a. Show a ⇒ Eq a ⇒ JsonCodec a → a → String → Effect Unit
 check codec val expectEncoded = do
   let encodedStr = stringifyWithIndent 2 $ encode codec val
@@ -313,5 +353,37 @@ main = do
             , "}"
             ]
 
-  quickCheck (propCodec genMySum (codecSample defaultEncoding))
+  quickCheck (propCodec arbitrary (codecSample defaultEncoding))
+
+  log "Check sum flat"
+  do
+    check codecSampleFlat FlatFoo
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"FlatFoo\""
+          , "}"
+          ]
+
+    check codecSampleFlat (FlatBar { errors: 42 })
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"FlatBar\","
+          , "  \"errors\": 42"
+          , "}"
+          ]
+
+    check codecSampleFlat (FlatBaz { active: true, name: "hello", pos: { x: 42, y: 42 } })
+      $ Str.joinWith "\n"
+          [ "{"
+          , "  \"tag\": \"FlatBaz\","
+          , "  \"active\": true,"
+          , "  \"name\": \"hello\","
+          , "  \"pos\": {"
+          , "    \"x\": 42,"
+          , "    \"y\": 42"
+          , "  }"
+          , "}"
+          ]
+
+    quickCheck (propCodec arbitrary codecSampleFlat)
 

Original file line number	Diff line number	Diff line change
`@@ -9,7 +9,7 @@`
`9`	`9`	`"pulp": "^16.0.0",`
`10`	`10`	`"purescript": "^0.15.0",`
`11`	`11`	`"purescript-psa": "^0.8.2",`
`12`		`- "purs-tidy": "^0.9.2",`
	`12`	`+ "purs-tidy": "^0.11.0",`
`13`	`13`	`"rimraf": "^3.0.0"`
`14`	`14`	`}`
`15`	`15`	`}`