Upgrade argonaut-codecs, which uses typed errors (#22)

Author: Serhii Khoma

bower.json

@@ -17,12 +17,13 @@
   "license": "MIT",
   "dependencies": {
     "purescript-argonaut-core": "^5.0.0",
-    "purescript-argonaut-codecs": "^6.0.2",
+    "purescript-argonaut-codecs": "^7.0.0",
     "purescript-generics-rep": "^6.1.1",
     "purescript-record": "^2.0.0"
   },
   "devDependencies": {
     "purescript-assert": "^4.1.0",
-    "purescript-console": "^4.2.0"
+    "purescript-console": "^4.2.0",
+    "purescript-exceptions": "^4.0.0"
   }
 }

src/Data/Argonaut/Decode/Generic/Rep.purs

@@ -15,8 +15,8 @@ module Data.Argonaut.Decode.Generic.Rep (
 import Prelude
 
 import Control.Alt ((<|>))
-import Data.Argonaut.Core (Json, toArray, toObject, toString)
-import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
+import Data.Argonaut.Core (Json, fromString, toArray, toObject, toString, fromArray)
+import Data.Argonaut.Decode (class DecodeJson, decodeJson, JsonDecodeError(..))
 import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
 import Data.Array (uncons)
 import Data.Bifunctor (lmap)
@@ -28,13 +28,13 @@ import Partial.Unsafe (unsafeCrashWith)
 import Prim.TypeError (class Fail, Text)
 
 class DecodeRep r where
-  decodeRepWith :: Encoding -> Json -> Either String r
+  decodeRepWith :: Encoding -> Json -> Either JsonDecodeError r
 
-decodeRep :: forall r. DecodeRep r => Json -> Either String r
+decodeRep :: forall r. DecodeRep r => Json -> Either JsonDecodeError r
 decodeRep = decodeRepWith defaultEncoding
 
 instance decodeRepNoConstructors :: DecodeRep Rep.NoConstructors where
-  decodeRepWith e _ = Left "Cannot decode empty data type"
+  decodeRepWith e _ = Left $ UnexpectedValue $ fromString "NoConstructors (Cannot decode empty data type)"
 
 instance decodeRepSum :: (DecodeRep a, DecodeRep b) => DecodeRep (Rep.Sum a b) where
   decodeRepWith e j = Rep.Inl <$> decodeRepWith e j <|> Rep.Inr <$> decodeRepWith e j
@@ -43,45 +43,45 @@ withTag ::
   Encoding ->
   Json ->
   String ->
-  Either String
+  Either JsonDecodeError
     { tag :: String
-    , decodingErr :: String -> String
+    , decodingErr :: JsonDecodeError -> JsonDecodeError
     }
 withTag e j name = do
-  let decodingErr msg = "When decoding a " <> name <> ": " <> msg
-  jObj <- note (decodingErr "expected an object") (toObject j)
-  jTag <- note (decodingErr $ "'" <> e.tagKey <> "' property is missing") (FO.lookup e.tagKey jObj)
-  tag <- note (decodingErr $ "'" <> e.tagKey <> "' property is not a string") (toString jTag)
+  let decodingErr = Named name
+  jObj <- note (decodingErr $ TypeMismatch "Object") (toObject j)
+  jTag <- note (decodingErr $ AtKey e.tagKey MissingValue) (FO.lookup e.tagKey jObj)
+  tag <- note (decodingErr $ AtKey e.tagKey $ TypeMismatch "String") (toString jTag)
   when (tag /= name) $
-    Left $ decodingErr $ "'" <> e.tagKey <> "' property has an incorrect value"
+    Left $ decodingErr $ AtKey e.tagKey $ UnexpectedValue $ fromString tag
   pure {tag, decodingErr}
 
 withTagAndValues ::
   Encoding ->
   Json ->
   String ->
-  Either String
+  Either JsonDecodeError
     { tag :: String
     , values :: Json
-    , decodingErr :: String -> String
+    , decodingErr :: JsonDecodeError -> JsonDecodeError
     }
 withTagAndValues e j name = do
   {tag, decodingErr} <- withTag e j name
-  jObj <- note (decodingErr "expected an object") (toObject j)
-  values <- note (decodingErr $ "'" <> e.valuesKey <> "' property is missing") (FO.lookup e.valuesKey jObj)
+  jObj <- note (decodingErr $ TypeMismatch "Object") (toObject j)
+  values <- note (decodingErr $ AtKey e.valuesKey MissingValue) (FO.lookup e.valuesKey jObj)
   pure {tag, values, decodingErr}
 
 construct ::
   forall e t s .
   DecodeRepArgs t =>
   Encoding ->
   Array Json ->
-  (String -> e) ->
+  (JsonDecodeError -> e) ->
   Either e (Rep.Constructor s t)
 construct e valuesArray decodingErr = do
   {init, rest} <- lmap decodingErr $ decodeRepArgs valuesArray
   when (rest /= []) $
-    Left $ decodingErr $ "'" <> e.valuesKey <> "' property had too many values"
+    Left $ decodingErr $ AtKey e.valuesKey $ UnexpectedValue (fromArray rest)
   pure $ Rep.Constructor init
 
 instance decodeRepConstructorNoArgs :: IsSymbol name => DecodeRep (Rep.Constructor name Rep.NoArguments) where
@@ -97,18 +97,18 @@ instance decodeRepConstructorArg :: (IsSymbol name, DecodeJson a) => DecodeRep (
     if e.unwrapSingleArguments
       then construct e [values] decodingErr
       else do
-        valuesArray <- note (decodingErr $ "'" <> e.valuesKey <> "' property is not an array") (toArray values)
+        valuesArray <- note (decodingErr $ AtKey e.valuesKey $ TypeMismatch "Array") (toArray values)
         construct e valuesArray decodingErr
 else
 instance decodeRepConstructor :: (IsSymbol name, DecodeRepArgs a) => DecodeRep (Rep.Constructor name a) where
   decodeRepWith e j = do
     let name = reflectSymbol (SProxy :: SProxy name)
     {tag, values, decodingErr} <- withTagAndValues e j name
-    valuesArray <- note (decodingErr $ "'" <> e.valuesKey <> "' property is not an array") (toArray values)
+    valuesArray <- note (decodingErr $ AtKey e.valuesKey $ TypeMismatch "Array") (toArray values)
     construct e valuesArray decodingErr
 
 class DecodeRepArgs r where
-  decodeRepArgs :: Array Json -> Either String {init :: r, rest :: Array Json}
+  decodeRepArgs :: Array Json -> Either JsonDecodeError {init :: r, rest :: Array Json}
 
 instance decodeRepArgsNoArguments :: DecodeRepArgs Rep.NoArguments where
   decodeRepArgs js = Right {init: Rep.NoArguments, rest: js}
@@ -121,40 +121,40 @@ instance decodeRepArgsProduct :: (DecodeRepArgs a, DecodeRepArgs b) => DecodeRep
 
 instance decodeRepArgsArgument :: (DecodeJson a) => DecodeRepArgs (Rep.Argument a) where
   decodeRepArgs js = do
-    {head, tail} <- note "too few values were present" (uncons js)
+    {head, tail} <- note (TypeMismatch "NonEmptyArray") (uncons js)
     {init: _, rest: tail} <<< Rep.Argument <$> decodeJson head
 
 -- | Decode `Json` representation of a value which has a `Generic` type.
-genericDecodeJson :: forall a r. Rep.Generic a r => DecodeRep r => Json -> Either String a
+genericDecodeJson :: forall a r. Rep.Generic a r => DecodeRep r => Json -> Either JsonDecodeError a
 genericDecodeJson = genericDecodeJsonWith defaultEncoding
 
 -- | Decode `Json` representation of a value which has a `Generic` type.
 -- | Takes a record for encoding settings.
-genericDecodeJsonWith :: forall a r. Rep.Generic a r => DecodeRep r => Encoding -> Json -> Either String a
+genericDecodeJsonWith :: forall a r. Rep.Generic a r => DecodeRep r => Encoding -> Json -> Either JsonDecodeError a
 genericDecodeJsonWith e = map Rep.to <<< decodeRepWith e
 
 -- | A function for decoding `Generic` sum types using string literal representations.
-decodeLiteralSum :: forall a r. Rep.Generic a r => DecodeLiteral r => Json -> Either String a
+decodeLiteralSum :: forall a r. Rep.Generic a r => DecodeLiteral r => Json -> Either JsonDecodeError a
 decodeLiteralSum = decodeLiteralSumWithTransform identity
 
 -- | A function for decoding `Generic` sum types using string literal representations.
 -- | Takes a function for transforming the tag name in encoding.
-decodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => DecodeLiteral r => (String -> String) -> Json -> Either String a
+decodeLiteralSumWithTransform :: forall a r. Rep.Generic a r => DecodeLiteral r => (String -> String) -> Json -> Either JsonDecodeError a
 decodeLiteralSumWithTransform tagNameTransform = map Rep.to <<< decodeLiteral tagNameTransform
 
 class DecodeLiteral r where
-  decodeLiteral :: (String -> String) -> Json -> Either String r
+  decodeLiteral :: (String -> String) -> Json -> Either JsonDecodeError r
 
 instance decodeLiteralSumInst :: (DecodeLiteral a, DecodeLiteral b) => DecodeLiteral (Rep.Sum a b) where
   decodeLiteral tagNameTransform j = Rep.Inl <$> decodeLiteral tagNameTransform j <|> Rep.Inr <$> decodeLiteral tagNameTransform j
 
 instance decodeLiteralConstructor :: (IsSymbol name) => DecodeLiteral (Rep.Constructor name (Rep.NoArguments)) where
   decodeLiteral tagNameTransform j = do
     let name = reflectSymbol (SProxy :: SProxy name)
-    let decodingErr msg = "When decoding a " <> name <> ": " <> msg
-    tag <- note (decodingErr "could not read string for constructor") (toString j)
+    let decodingErr = Named name
+    tag <- note (decodingErr $ TypeMismatch "String") (toString j)
     when (tag /= tagNameTransform name) $
-      Left $ decodingErr "string literal " <> tag <> " had an incorrect value."
+      Left $ decodingErr $ UnexpectedValue (fromString tag)
     pure $ Rep.Constructor (Rep.NoArguments)
 
 

test/Main.purs

@@ -4,19 +4,21 @@ module Test.Main
 
 import Prelude
 
-import Effect (Effect)
-import Effect.Console (log)
-import Data.Argonaut.Core (stringify)
+import Data.Argonaut.Core (Json, stringify)
 import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
 import Data.Argonaut.Decode.Generic.Rep (class DecodeLiteral, decodeLiteralSumWithTransform, genericDecodeJson, genericDecodeJsonWith)
 import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
 import Data.Argonaut.Encode.Generic.Rep (class EncodeLiteral, encodeLiteralSumWithTransform, genericEncodeJson, genericEncodeJsonWith)
-import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
 import Data.Argonaut.Parser (jsonParser)
-import Data.Either (Either(..), fromRight)
+import Data.Argonaut.Types.Generic.Rep (Encoding, defaultEncoding)
+import Data.Either (Either(..), either, fromRight)
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.String (toLower, toUpper)
+import Effect (Effect)
+import Effect.Class (liftEffect)
+import Effect.Console (log)
+import Effect.Exception (throw)
 import Partial.Unsafe (unsafePartial)
 import Test.Assert (assert)
 
@@ -90,6 +92,9 @@ instance encodeJsonIgnoreNullaryArgs :: EncodeJson IgnoreNullaryArgs where
 instance decodeJsonIgnoreNullaryArgs :: DecodeJson IgnoreNullaryArgs where
   decodeJson a = genericDecodeJson a
 
+jsonParser' :: String -> Effect Json
+jsonParser' = either throw pure <<< jsonParser
+
 main :: Effect Unit
 main = do
   example $ Either $ Left "foo"
@@ -113,7 +118,8 @@ main = do
 
   example $ NA1 42
   example $ NA0
-  assert $ (jsonParser """{"tag":"NA0"}""" >>= decodeJson) == Right NA0
+  json <- jsonParser' """{"tag":"NA0"}"""
+  assert $ (decodeJson json) == Right NA0
 
   where
   example :: forall a. Show a => Eq a => EncodeJson a => DecodeJson a => a -> Effect Unit