Merge pull request #11 from garyb/nest-for-tagged

Nest for tagged

Author: garyb

src/Data/Codec/Argonaut/Migration.purs

@@ -3,6 +3,7 @@ module Data.Codec.Argonaut.Migration
   , updateField
   , addDefaultOrUpdateField
   , renameField
+  , nestForTagged
   ) where
 
 import Prelude
@@ -11,8 +12,9 @@ import Data.Argonaut.Core as J
 import Data.Codec (basicCodec)
 import Data.Codec.Argonaut (JsonCodec)
 import Data.Maybe (Maybe(..), maybe, fromMaybe)
-import Data.Tuple (uncurry)
 import Data.StrMap as SM
+import Data.StrMap.ST as SMST
+import Data.Tuple (Tuple(..), uncurry)
 
 -- | When dealing with a JSON object that may be missing a field, this codec
 -- | can be used to alter the JSON before parsing to ensure a default value is
@@ -42,6 +44,46 @@ renameField oldName newName = basicCodec (pure <<< dec) id
   rename ∷ J.JObject → J.JObject
   rename obj = maybe obj (uncurry (SM.insert newName)) (SM.pop oldName obj)
 
+-- | Prepares an object from a legacy codec for use in a `Variant` or
+-- | `taggedSum` codec.
+-- |
+-- | For an input like:
+-- | ```{ "tag": "tag", "x": 1, "y": 2, "z": 3 }```
+-- | the result will be:
+-- | ```{ "tag": "tag", "value": { "x": 1, "y": 2, "z": 3 } }```
+-- |
+-- | For an input like:
+-- | ```{ "tag": "tag", "value": 1, "foo": 2 }```
+-- | the result will be:
+-- | ```{ "tag": "tag", "value": { "value": 1, "foo": 2 }```
+-- |
+-- | If the value is already in the expected form, where there is only `value`
+-- | and no other keys (aside from `tag`):
+-- | ```{ "tag": "tag", "value": true }```
+-- | the result will be the same as the input.
+-- |
+-- | If the tag field is missing from the input, it will also be missing in the
+-- | output.
+nestForTagged ∷ JsonCodec J.Json
+nestForTagged = basicCodec (pure <<< dec) id
+  where
+  dec ∷ J.Json → J.Json
+  dec j = J.foldJsonObject j (J.fromObject <<< rewrite) j
+  rewrite ∷ J.JObject → J.JObject
+  rewrite obj =
+    case SM.pop "tag" obj of
+      Nothing → SM.pureST do
+        result ← SMST.new
+        SMST.poke result "value" (mkValue obj)
+      Just (Tuple tagValue obj') → SM.pureST do
+        result ← SMST.new
+        _ ← SMST.poke result "tag" tagValue
+        SMST.poke result "value" (mkValue obj')
+  mkValue ∷ J.JObject → J.Json
+  mkValue obj = case SM.pop "value" obj of
+    Just (Tuple valueValue obj') | SM.isEmpty obj' → valueValue
+    _ → J.fromObject obj
+
 alterField ∷ String → (Maybe J.Json → Maybe J.Json) → JsonCodec J.Json
 alterField field f = basicCodec (pure <<< dec) id
   where

test/Test/Migration.purs

@@ -4,16 +4,19 @@ import Prelude
 
 import Control.Monad.Eff.Console (log)
 import Data.Argonaut.Core as J
+import Data.Argonaut.Gen as GenJ
 import Data.Codec ((<~<))
 import Data.Codec.Argonaut.Common as JA
 import Data.Codec.Argonaut.Migration as JAM
 import Data.Either (Either(..))
 import Data.Maybe (Maybe(..), fromMaybe, maybe)
-import Data.String.Gen (genAsciiString)
 import Data.StrMap as SM
+import Data.StrMap.Gen as GenSM
+import Data.String.Gen (genAsciiString)
+import Data.Tuple (Tuple(..))
 import Test.QuickCheck (Result(..), QC, quickCheck, (===))
 import Test.QuickCheck.Gen (Gen)
-import Test.Util (genJObject)
+import Test.Util (genJObject, propCodec)
 
 main :: QC () Unit
 main = do
@@ -35,6 +38,12 @@ main = do
   log "Checking renameField renames a field"
   quickCheck propDefaultFieldPreservesOriginal
 
+  log "Checking nestForTagged moves all expected fields under `value`"
+  quickCheck propNestForTaggedMovesUnderValue
+
+  log "Checking nestForTagged is idempotent"
+  quickCheck propNestForTaggedIdempotent
+
 propDefaultFieldAdded ∷ Gen Result
 propDefaultFieldAdded = do
   let expectedValue = J.fromString "it's here"
@@ -87,6 +96,27 @@ propRenameField = do
   pure $ testMigrationCodec { key: newKey, expectedValue, input }
     $ JA.jobject <~< JAM.renameField oldKey newKey
 
+propNestForTaggedMovesUnderValue ∷ Gen Result
+propNestForTaggedMovesUnderValue = do
+  values ← GenSM.genStrMap genAsciiString GenJ.genJson
+  -- TODO: only-value
+  let expectedValue = J.fromObject (SM.delete "tag" values)
+  pure $ testMigrationCodec { key: "value", expectedValue, input: values }
+    $ JA.jobject <~< JAM.nestForTagged
+
+propNestForTaggedIdempotent ∷ Gen Result
+propNestForTaggedIdempotent = do
+  propCodec genTagged JAM.nestForTagged
+  where
+    genTagged = do
+      tag ← genAsciiString
+      expectedValue ← GenJ.genJson
+      pure $ J.fromObject $
+        SM.fromFoldable
+          [ Tuple "tag" (J.fromString tag)
+          , Tuple "value" expectedValue
+          ]
+
 testMigrationCodec
   ∷ { key ∷ String
     , expectedValue ∷ J.Json