Merge pull request #4 from garyb/sums

Sum encoding again

Author: garyb

src/Data/Codec/Argonaut/Common.purs

@@ -5,40 +5,35 @@ module Data.Codec.Argonaut.Common
 
 import Prelude hiding (map)
 
-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, record, recordProp, string, (<~<), (~))
-import Data.Codec.Argonaut.Sum (Tag(..), taggedSum)
+import Data.Codec.Argonaut.Sum (taggedSum)
 import Data.Either (Either(..))
+import Data.Functor as F
 import Data.List as L
 import Data.Map as M
 import Data.Maybe (Maybe(..))
 import Data.Profunctor (dimap)
 import Data.StrMap as SM
-import Data.StrMap.ST as SMST
 import Data.Tuple (Tuple(..), fst, snd)
 
 -- | A codec for `Maybe` values.
 maybe ∷ ∀ a. JsonCodec a → JsonCodec (Maybe a)
-maybe codec = basicCodec dec enc
+maybe codec = taggedSum "Maybe" printTag parseTag dec enc
   where
-  dec j = do
-    obj ← decode jobject j
-    tag ← decode (prop "tag" string) obj
-    case tag of
-      "Just" → Just <$> decode (prop "value" codec) obj
-      "Nothing" → pure Nothing
-      _ → Left (AtKey "tag" (UnexpectedValue (J.fromString tag)))
-  enc x = encode jobject $ SM.pureST do
-    obj ← SMST.new
-    case x of
-      Nothing →
-        SMST.poke obj "tag" (J.fromString "Nothing")
-      Just a → do
-        _ ← SMST.poke obj "tag" (J.fromString "Just")
-        SMST.poke obj "value" (encode codec a)
+  printTag = case _ of
+    false → "Nothing"
+    true → "Just"
+  parseTag = case _ of
+    "Nothing" → Just false
+    "Just" → Just true
+    _ → Nothing
+  dec = case _ of
+    false → Left Nothing
+    true → Right (F.map Just <<< decode codec)
+  enc = case _ of
+    Nothing → Tuple false Nothing
+    Just a → Tuple true (Just (encode codec a))
 
 -- | A codec for `Tuple` values.
 -- |
@@ -51,15 +46,21 @@ tuple codecA codecB = indexedArray "Tuple" $
 
 -- | A codec for `Either` values.
 either ∷ ∀ a b. JsonCodec a → JsonCodec b → JsonCodec (Either a b)
-either codecA codecB = taggedSum dec enc
+either codecA codecB = taggedSum "Either" printTag parseTag dec enc
   where
-  dec tag json = case tag of
-    Tag "Left" → BF.bimap (AtKey "value") Left (decode codecA json)
-    Tag "Right" → BF.bimap (AtKey "value") Right (decode codecB json)
-    Tag t → Left (AtKey "tag" (UnexpectedValue (J.fromString t)))
+  printTag = case _ of
+    true → "Left"
+    false → "Right"
+  parseTag = case _ of
+    "Left" → Just true
+    "Right" → Just false
+    _ → Nothing
+  dec = case _ of
+    true → Right (F.map Left <<< decode codecA)
+    false → Right (F.map Right <<< decode codecB)
   enc = case _ of
-    Left a → Tuple (Tag "Left") (encode codecA a)
-    Right b → Tuple (Tag "Right") (encode codecB b)
+    Left a → Tuple true (Just (encode codecA a))
+    Right b → Tuple false (Just (encode codecB b))
 
 -- | A codec for `List` values.
 -- |

src/Data/Codec/Argonaut/Sum.purs

@@ -1,5 +1,5 @@
 module Data.Codec.Argonaut.Sum
-  ( Tag(..)
+  ( enumSum
   , taggedSum
   ) where
 
@@ -8,52 +8,73 @@ import Prelude
 import Control.Monad.Reader (ReaderT(..))
 import Control.Monad.Writer (Writer, writer)
 import Data.Argonaut.Core as J
+import Data.Bifunctor (lmap)
 import Data.Codec (GCodec(..), decode, encode)
-import Data.Codec.Argonaut (JsonCodec, JsonDecodeError, jobject, json, prop, string)
-import Data.Either as E
-import Data.Newtype (class Newtype)
+import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..), jobject, json, prop, string)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), maybe)
 import Data.Profunctor.Star (Star(..))
 import Data.StrMap as SM
 import Data.StrMap.ST as SMST
 import Data.Tuple (Tuple(..))
 
--- | A tag value for a case in a sum type.
-newtype Tag = Tag String
-
-derive newtype instance eqTag ∷ Eq Tag
-derive newtype instance ordTag ∷ Ord Tag
-derive instance newtypeTag ∷ Newtype Tag _
+-- | A helper for defining JSON codecs for "enum" sum types, where every
+-- | constructor is nullary, and the type will be encoded as a string.
+enumSum
+  ∷ ∀ a
+  . (a → String)
+  → (String → Maybe a)
+  → JsonCodec a
+enumSum printTag parseTag = GCodec dec enc
+  where
+  dec ∷ ReaderT J.Json (Either JsonDecodeError) a
+  dec = ReaderT \j → do
+    value ← decode string j
+    case parseTag value of
+      Just a → Right a
+      Nothing → Left (UnexpectedValue j)
+  enc ∷ Star (Writer J.Json) a a
+  enc = Star \a → writer $ Tuple a (encode string (printTag a))
 
--- | A helper for defining JSON codecs for sum types.
+-- | A helper for defining JSON codecs for sum types. To ensure exhaustivity
+-- | there needs to be a mapping to and from a tag type for the type to be
+-- | encoded.
 -- |
--- | - The first function attempts to decode a case, using the specified tag.
--- | - The second function encodes a case, returning an appropriate tag and
--- |   encoded value.
+-- | - The first argument is the name of the type being decoded, for error
+-- |   message purposes.
+-- | - The second argument maps a tag value to a string to use in the encoding.
+-- | - The second argument maps a string back to a tag value during decoding.
+-- | - The third argument returns either a constant value or a decoder function
+-- |   based on a tag value.
+-- | - The fourth argument returns a tag value and optional encoded value to
+-- |   store for a constructor of the sum.
 taggedSum
-  ∷ ∀ a
-  . (Tag → J.Json → E.Either JsonDecodeError a)
-  → (a → Tuple Tag J.Json)
+  ∷ ∀ tag a
+  . String
+  → (tag → String)
+  → (String → Maybe tag)
+  → (tag → Either a (J.Json → Either JsonDecodeError a))
+  → (a → Tuple tag (Maybe J.Json))
   → JsonCodec a
-taggedSum f g = GCodec (decodeCase f) (encodeCase g)
-
-decodeCase
-  ∷ ∀ a
-  . (Tag → J.Json → E.Either JsonDecodeError a)
-  → ReaderT J.Json (E.Either JsonDecodeError) a
-decodeCase f = ReaderT \j → do
-  obj ← decode jobject j
-  tag ← decode (prop "tag" string) obj
-  value ← decode (prop "value" json) obj
-  f (Tag tag) value
-
-encodeCase
-  ∷ ∀ a
-  . (a → Tuple Tag J.Json)
-  → Star (Writer J.Json) a a
-encodeCase f = Star case _ of
-  a | Tuple (Tag tag) value ← f a →
-    writer $ Tuple a $ encode jobject $
-      SM.pureST do
-        obj ← SMST.new
-        _ ← SMST.poke obj "tag" (encode string tag)
-        SMST.poke obj "value" value
+taggedSum name printTag parseTag f g = GCodec decodeCase encodeCase
+  where
+  decodeCase ∷ ReaderT J.Json (Either JsonDecodeError) a
+  decodeCase = ReaderT \j → lmap (Named name) do
+    obj ← decode jobject j
+    tag ← decode (prop "tag" string) obj
+    case parseTag tag of
+      Nothing → Left (AtKey "tag" (UnexpectedValue (J.fromString tag)))
+      Just t →
+        case f t of
+          Left a → pure a
+          Right decoder → do
+            value ← decode (prop "value" json) obj
+            lmap (AtKey "value") (decoder value)
+  encodeCase ∷ Star (Writer J.Json) a a
+  encodeCase = Star case _ of
+    a | Tuple tag value ← g a →
+      writer $ Tuple a $ encode jobject $
+        SM.pureST do
+          obj ← SMST.new
+          _ ← SMST.poke obj "tag" (encode string (printTag tag))
+          maybe (pure obj) (SMST.poke obj "value") value