Merge pull request #3 from garyb/misc

Misc additions

Author: garyb

bower.json

@@ -18,7 +18,8 @@
   "dependencies": {
     "purescript-argonaut-core": "^3.1.0",
     "purescript-codec": "^2.0.0",
-    "purescript-generics-rep": "^5.1.0"
+    "purescript-generics-rep": "^5.1.0",
+    "purescript-variant": "^1.1.0"
   },
   "devDependencies": {
     "purescript-argonaut-codecs": "^3.1.0",

src/Data/Codec/Argonaut.purs

@@ -54,7 +54,7 @@ type JsonCodec a = BasicCodec (Either JsonDecodeError) J.Json a
 -- | Error type for failures while decoding.
 data JsonDecodeError
   = TypeMismatch String
-  | UnexpectedValue String
+  | UnexpectedValue J.Json
   | AtIndex Int JsonDecodeError
   | AtKey String JsonDecodeError
   | Named String JsonDecodeError
@@ -74,7 +74,7 @@ printJsonDecodeError err =
   where
     go = case _ of
       TypeMismatch ty → "  Expected value of type '" <> ty <> "'."
-      UnexpectedValue val → "  Unexpected value '" <> val <> "'."
+      UnexpectedValue val → "  Unexpected value " <> J.stringify val <> "."
       AtIndex ix inner → "  At array index " <> show ix <> ":\n" <> go inner
       AtKey key inner → "  At object key " <> key <> ":\n" <> go inner
       Named name inner → "  Under '" <> name <> "':\n" <> go inner

src/Data/Codec/Argonaut/Common.purs

@@ -30,7 +30,7 @@ maybe codec = basicCodec dec enc
     case tag of
       "Just" → Just <$> decode (prop "value" codec) obj
       "Nothing" → pure Nothing
-      _ → Left (AtKey "tag" (UnexpectedValue tag))
+      _ → Left (AtKey "tag" (UnexpectedValue (J.fromString tag)))
   enc x = encode jobject $ SM.pureST do
     obj ← SMST.new
     case x of
@@ -56,7 +56,7 @@ either codecA codecB = taggedSum dec enc
   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 t))
+    Tag t → Left (AtKey "tag" (UnexpectedValue (J.fromString t)))
   enc = case _ of
     Left a → Tuple (Tag "Left") (encode codecA a)
     Right b → Tuple (Tag "Right") (encode codecB b)

src/Data/Codec/Argonaut/Migration.purs

@@ -0,0 +1,32 @@
+module Data.Codec.Argonaut.Migration where
+
+import Prelude
+
+import Data.Argonaut.Core as J
+import Data.Codec (basicCodec)
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Tuple (uncurry)
+import Data.StrMap as SM
+
+-- | 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
+-- | present instead.
+addDefaultField ∷ String → J.Json → JsonCodec J.Json
+addDefaultField field defaultValue = basicCodec (pure <<< dec) id
+  where
+  dec ∷ J.Json → J.Json
+  dec j = J.foldJsonObject j (J.fromObject <<< setDefault) j
+  setDefault ∷ J.JObject → J.JObject
+  setDefault = SM.alter (maybe (Just defaultValue) Just) field
+
+-- | When dealing with a JSON object that has had a field name changed, this
+-- | codec can be used to alter the JSON before parsing to ensure the new field
+-- | name is used instead
+renameField ∷ String → String → JsonCodec J.Json
+renameField oldName newName = basicCodec (pure <<< dec) id
+  where
+  dec ∷ J.Json → J.Json
+  dec j = J.foldJsonObject j (J.fromObject <<< rename) j
+  rename ∷ J.JObject → J.JObject
+  rename obj = maybe obj (uncurry (SM.insert newName)) (SM.pop oldName obj)

src/Data/Codec/Argonaut/Variant.purs

@@ -0,0 +1,59 @@
+module Data.Codec.Argonaut.Variant where
+
+import Prelude
+
+import Control.Monad.Reader (ReaderT(..), runReaderT)
+import Control.Monad.Writer (Writer, writer)
+import Data.Argonaut.Core as J
+import Data.Codec (GCodec(..))
+import Data.Codec.Argonaut (JsonCodec, JsonDecodeError(..), decode, encode, jobject, json, prop, string)
+import Data.Either (Either(..))
+import Data.Newtype (un)
+import Data.Profunctor.Star (Star(..))
+import Data.StrMap as SM
+import Data.StrMap.ST as SMST
+import Data.Symbol (class IsSymbol, reflectSymbol)
+import Data.Tuple (Tuple(..))
+import Data.Variant (SProxy, Variant, case_, inj, on)
+import Unsafe.Coerce (unsafeCoerce)
+
+variant ∷ JsonCodec (Variant ())
+variant = GCodec (ReaderT (Left <<< UnexpectedValue)) (Star case_)
+
+variantCase
+  ∷ ∀ l a r r'
+  . IsSymbol l
+  ⇒ RowCons l a r r'
+  ⇒ SProxy l
+  → Either a (JsonCodec a)
+  → JsonCodec (Variant r)
+  → JsonCodec (Variant r')
+variantCase proxy eacodec (GCodec dec enc) = GCodec dec' enc'
+  where
+
+  dec' ∷ ReaderT J.Json (Either JsonDecodeError) (Variant r')
+  dec' = ReaderT \j → do
+    obj ← decode jobject j
+    tag ← decode (prop "tag" string) obj
+    if tag == reflectSymbol proxy
+      then case eacodec of
+        Left a → pure (inj proxy a)
+        Right codec → do
+          value ← decode (prop "value" json) obj
+          inj proxy <$> decode codec value
+      else coerceR <$> runReaderT dec j
+
+  enc' ∷ Star (Writer J.Json) (Variant r') (Variant r')
+  enc' = Star \v →
+    on proxy
+      (\v' → writer $ Tuple v $ encode jobject $
+        SM.pureST do
+          obj ← SMST.new
+          _ ← SMST.poke obj "tag" (encode string (reflectSymbol proxy))
+          case eacodec of
+            Left _ → pure obj
+            Right codec → SMST.poke obj "value" (encode codec v'))
+      (\v' → un Star enc v' $> v) v
+
+  coerceR ∷ Variant r → Variant r'
+  coerceR = unsafeCoerce

test/Test/Main.purs

@@ -3,10 +3,12 @@ module Test.Main where
 import Prelude
 
 import Control.Monad.Eff.Console (log)
-import Test.Prim as Prim
 import Test.Common as Common
 import Test.Compat as Compat
+import Test.Migration as Migration
+import Test.Prim as Prim
 import Test.QuickCheck (QC)
+import Test.Variant as Variant
 
 main :: QC () Unit
 main = do
@@ -21,3 +23,11 @@ main = do
   log "Checking Compat codecs"
   log "------------------------------------------------------------"
   Compat.main
+  log ""
+  log "Checking Variant codecs"
+  log "------------------------------------------------------------"
+  Variant.main
+  log ""
+  log "Checking Migration codecs"
+  log "------------------------------------------------------------"
+  Migration.main

test/Test/Migration.purs

@@ -0,0 +1,68 @@
+module Test.Migration where
+
+import Prelude
+
+import Control.Monad.Eff.Console (log)
+import Data.Argonaut.Core as J
+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(..))
+import Data.String.Gen (genAsciiString)
+import Data.StrMap as SM
+import Test.QuickCheck (Result(..), QC, quickCheck, (===))
+import Test.QuickCheck.Gen (Gen)
+import Test.Util (genJObject)
+
+main :: QC () Unit
+main = do
+  log "Checking addDefaultField adds a field if it is missing"
+  quickCheck propDefaultFieldAdded
+
+  log "Checking addDefaultField preserves an existing value if it's already present"
+  quickCheck propDefaultFieldPreservesOriginal
+
+  log "Checking renameField renames a field"
+  quickCheck propDefaultFieldPreservesOriginal
+
+propDefaultFieldAdded ∷ Gen Result
+propDefaultFieldAdded = do
+  let expectedValue = J.fromString "it's here"
+  missingKey ← genAsciiString
+  input ← SM.delete missingKey <$> genJObject
+  pure $ testMigrationCodec { key: missingKey, expectedValue, input }
+    $ JA.jobject <~< JAM.addDefaultField missingKey expectedValue
+
+propDefaultFieldPreservesOriginal ∷ Gen Result
+propDefaultFieldPreservesOriginal = do
+  let expectedValue = J.fromString "it's here"
+  let unexpectedValue = J.fromString "it shouldn't be here"
+  missingKey ← genAsciiString
+  input ← SM.insert missingKey expectedValue <$> genJObject
+  pure $ testMigrationCodec { key: missingKey, expectedValue, input }
+    $ JA.jobject <~< JAM.addDefaultField missingKey unexpectedValue
+
+propRenameField ∷ Gen Result
+propRenameField = do
+  let expectedValue = J.fromString "it's here"
+  oldKey ← genAsciiString
+  newKey ← genAsciiString
+  input ← SM.insert oldKey expectedValue <$> genJObject
+  pure $ testMigrationCodec { key: newKey, expectedValue, input }
+    $ JA.jobject <~< JAM.renameField oldKey newKey
+
+testMigrationCodec
+  ∷ { key ∷ String
+    , expectedValue ∷ J.Json
+    , input ∷ J.JObject
+    }
+  → JA.JsonCodec J.JObject
+  → Result
+testMigrationCodec { key, expectedValue, input } codec =
+  case JA.decode codec (J.fromObject input) of
+    Left err → Failed (JA.printJsonDecodeError err)
+    Right obj →
+      case SM.lookup key obj of
+        Just value → value === expectedValue
+        Nothing → Failed (JA.printJsonDecodeError (JA.AtKey key JA.MissingValue))

test/Test/Util.purs

@@ -3,8 +3,12 @@ module Test.Util where
 import Prelude
 
 import Control.Monad.Gen as Gen
+import Data.Argonaut.Core as J
+import Data.Argonaut.Gen as GenJ
 import Data.Codec.Argonaut.Common as JA
 import Data.Either (Either(..))
+import Data.String.Gen (genAsciiString)
+import Data.StrMap.Gen as SMG
 import Test.QuickCheck (Result(..), (<?>))
 import Test.QuickCheck.Gen (Gen)
 
@@ -23,3 +27,6 @@ propCodec = propCodec' eq show
 
 genInt ∷ Gen Int
 genInt = Gen.chooseInt (-100000) 100000
+
+genJObject ∷ Gen J.JObject
+genJObject = SMG.genStrMap genAsciiString GenJ.genJson

test/Test/Variant.purs

@@ -0,0 +1,62 @@
+module Test.Variant where
+
+import Prelude
+
+import Control.Monad.Eff.Console (log)
+import Control.Monad.Gen.Common as GenC
+import Data.Codec.Argonaut.Common as JA
+import Data.Codec.Argonaut.Variant as JAV
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Profunctor (dimap)
+import Data.String.Gen (genAsciiString)
+import Data.Symbol (SProxy(..))
+import Data.Variant as V
+import Test.QuickCheck (QC, quickCheck)
+import Test.Util (genInt, propCodec)
+
+main :: QC () Unit
+main = do
+  log "Checking Maybe-variant codec"
+  quickCheck $
+    propCodec
+      (GenC.genMaybe genAsciiString)
+      (codecMaybe JA.string)
+
+  log "Checking Either-variant codec"
+  quickCheck $
+    propCodec
+      (GenC.genEither genAsciiString genInt)
+      (codecEither JA.string JA.int)
+
+codecMaybe ∷ ∀ a. JA.JsonCodec a → JA.JsonCodec (Maybe a)
+codecMaybe codecA =
+  dimap toVariant fromVariant
+    (JAV.variant
+      # JAV.variantCase _Just (Right codecA)
+      # JAV.variantCase _Nothing (Left unit))
+  where
+  toVariant = case _ of
+    Just a → V.inj _Just a
+    Nothing → V.inj _Nothing unit
+  fromVariant = V.case_
+    # V.on _Just Just
+    # V.on _Nothing (const Nothing)
+  _Just = SProxy ∷ SProxy "just"
+  _Nothing = SProxy ∷ SProxy "nothing"
+
+codecEither ∷ ∀ a b. JA.JsonCodec a → JA.JsonCodec b → JA.JsonCodec (Either a b)
+codecEither codecA codecB =
+  dimap toVariant fromVariant
+    (JAV.variant
+      # JAV.variantCase _Left (Right codecA)
+      # JAV.variantCase _Right (Right codecB))
+  where
+  toVariant = case _ of
+    Left a → V.inj _Left a
+    Right b → V.inj _Right b
+  fromVariant = V.case_
+    # V.on _Left Left
+    # V.on _Right Right
+  _Left = SProxy ∷ SProxy "left"
+  _Right = SProxy ∷ SProxy "right"