From 08e94fcf56a319b883683bb3a51eebbb0dbc5916 Mon Sep 17 00:00:00 2001
From: Jordan Martinez <jordanalex.martinez@protonmail.com>
Date: Thu, 23 Jun 2022 20:15:53 -0500
Subject: [PATCH] Add optional custom ctor via voidable sum pattern

---
 src/Data/Argonaut/Decode.purs             |   4 +-
 src/Data/Argonaut/Decode/Class.purs       |   8 +-
 src/Data/Argonaut/Decode/Combinators.purs |  10 +-
 src/Data/Argonaut/Decode/Decoders.purs    | 126 +++++++++++-----------
 src/Data/Argonaut/Decode/Error.purs       |  26 +++--
 src/Data/Argonaut/Decode/Parser.purs      |   4 +-
 6 files changed, 93 insertions(+), 85 deletions(-)

diff --git a/src/Data/Argonaut/Decode.purs b/src/Data/Argonaut/Decode.purs
index 29bfda0..c28bca9 100644
--- a/src/Data/Argonaut/Decode.purs
+++ b/src/Data/Argonaut/Decode.purs
@@ -10,10 +10,10 @@ import Prelude
 
 import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
 import Data.Argonaut.Decode.Combinators (getField, getFieldOptional, getFieldOptional', defaultField, (.:), (.:!), (.:?), (.!=))
-import Data.Argonaut.Decode.Error (JsonDecodeError(..), printJsonDecodeError)
+import Data.Argonaut.Decode.Error (JsonDecodeError'(..), printJsonDecodeError')
 import Data.Argonaut.Decode.Parser (parseJson)
 import Data.Either (Either)
 
 -- | Parse and decode a json in one step.
-fromJsonString :: forall json. DecodeJson json => String -> Either JsonDecodeError json
+fromJsonString :: forall customErr json. DecodeJson json => String -> Either (JsonDecodeError' customErr) json
 fromJsonString = parseJson >=> decodeJson
diff --git a/src/Data/Argonaut/Decode/Class.purs b/src/Data/Argonaut/Decode/Class.purs
index aa55206..9a66ef8 100644
--- a/src/Data/Argonaut/Decode/Class.purs
+++ b/src/Data/Argonaut/Decode/Class.purs
@@ -3,7 +3,7 @@ module Data.Argonaut.Decode.Class where
 import Data.Argonaut.Decode.Decoders
 
 import Data.Argonaut.Core (Json, toObject)
-import Data.Argonaut.Decode.Error (JsonDecodeError(..))
+import Data.Argonaut.Decode.Error (JsonDecodeError'(..))
 import Data.Array.NonEmpty (NonEmptyArray)
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..))
@@ -26,7 +26,7 @@ import Record as Record
 import Type.Proxy (Proxy(..))
 
 class DecodeJson a where
-  decodeJson :: Json -> Either JsonDecodeError a
+  decodeJson :: forall customErr. Json -> Either (JsonDecodeError' customErr) a
 
 instance decodeIdentity :: DecodeJson a => DecodeJson (Identity a) where
   decodeJson = decodeIdentity decodeJson
@@ -105,7 +105,7 @@ instance decodeRecord ::
       Nothing -> Left $ TypeMismatch "Object"
 
 class GDecodeJson (row :: Row Type) (list :: RL.RowList Type) | list -> row where
-  gDecodeJson :: forall proxy. FO.Object Json -> proxy list -> Either JsonDecodeError (Record row)
+  gDecodeJson :: forall customErr proxy. FO.Object Json -> proxy list -> Either (JsonDecodeError' customErr) (Record row)
 
 instance gDecodeJsonNil :: GDecodeJson () RL.Nil where
   gDecodeJson _ _ = Right {}
@@ -134,7 +134,7 @@ instance gDecodeJsonCons ::
         Left $ AtKey fieldName MissingValue
 
 class DecodeJsonField a where
-  decodeJsonField :: Maybe Json -> Maybe (Either JsonDecodeError a)
+  decodeJsonField :: forall customErr. Maybe Json -> Maybe (Either (JsonDecodeError' customErr) a)
 
 instance decodeFieldMaybe ::
   DecodeJson a =>
diff --git a/src/Data/Argonaut/Decode/Combinators.purs b/src/Data/Argonaut/Decode/Combinators.purs
index 0625cde..4d09b22 100644
--- a/src/Data/Argonaut/Decode/Combinators.purs
+++ b/src/Data/Argonaut/Decode/Combinators.purs
@@ -12,7 +12,7 @@ module Data.Argonaut.Decode.Combinators
 import Prelude
 
 import Data.Argonaut.Core (Json)
-import Data.Argonaut.Decode.Error (JsonDecodeError)
+import Data.Argonaut.Decode.Error (JsonDecodeError')
 import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson)
 import Data.Either (Either)
 import Data.Maybe (Maybe, fromMaybe)
@@ -23,7 +23,7 @@ import Data.Argonaut.Decode.Decoders as Decoders
 -- |
 -- | Use this accessor if the key and value *must* be present in your object.
 -- | If the key and value are optional, use `getFieldOptional'` (`.:?`) instead.
-getField :: forall a. DecodeJson a => FO.Object Json -> String -> Either JsonDecodeError a
+getField :: forall customErr a. DecodeJson a => FO.Object Json -> String -> Either (JsonDecodeError' customErr) a
 getField = Decoders.getField decodeJson
 
 infix 7 getField as .:
@@ -35,7 +35,7 @@ infix 7 getField as .:
 -- |
 -- | Use this accessor if the key and value are optional in your object.
 -- | If the key and value are mandatory, use `getField` (`.:`) instead.
-getFieldOptional' :: forall a. DecodeJson a => FO.Object Json -> String -> Either JsonDecodeError (Maybe a)
+getFieldOptional' :: forall customErr a. DecodeJson a => FO.Object Json -> String -> Either (JsonDecodeError' customErr) (Maybe a)
 getFieldOptional' = Decoders.getFieldOptional' decodeJson
 
 infix 7 getFieldOptional' as .:?
@@ -48,7 +48,7 @@ infix 7 getFieldOptional' as .:?
 -- | This function will treat `null` as a value and attempt to decode it into your desired type.
 -- | If you would like to treat `null` values the same as absent values, use
 -- | `getFieldOptional'` (`.:?`) instead.
-getFieldOptional :: forall a. DecodeJson a => FO.Object Json -> String -> Either JsonDecodeError (Maybe a)
+getFieldOptional :: forall customErr a. DecodeJson a => FO.Object Json -> String -> Either (JsonDecodeError' customErr) (Maybe a)
 getFieldOptional = Decoders.getFieldOptional decodeJson
 
 infix 7 getFieldOptional as .:!
@@ -72,7 +72,7 @@ infix 7 getFieldOptional as .:!
 -- |     baz <- x .:? "baz" .!= false -- optional field with default value of `false`
 -- |     pure $ MyType { foo, bar, baz }
 -- | ```
-defaultField :: forall a. Either JsonDecodeError (Maybe a) -> a -> Either JsonDecodeError a
+defaultField :: forall customErr a. Either (JsonDecodeError' customErr) (Maybe a) -> a -> Either (JsonDecodeError' customErr) a
 defaultField parser default = fromMaybe default <$> parser
 
 infix 6 defaultField as .!=
diff --git a/src/Data/Argonaut/Decode/Decoders.purs b/src/Data/Argonaut/Decode/Decoders.purs
index bfab8db..0879ec8 100644
--- a/src/Data/Argonaut/Decode/Decoders.purs
+++ b/src/Data/Argonaut/Decode/Decoders.purs
@@ -3,7 +3,7 @@ module Data.Argonaut.Decode.Decoders where
 import Prelude
 
 import Data.Argonaut.Core (Json, caseJsonBoolean, caseJsonNull, caseJsonNumber, caseJsonString, isNull, toArray, toObject, toString, fromString)
-import Data.Argonaut.Decode.Error (JsonDecodeError(..))
+import Data.Argonaut.Decode.Error (JsonDecodeError'(..))
 import Data.Array as Arr
 import Data.Array.NonEmpty (NonEmptyArray)
 import Data.Array.NonEmpty as NEA
@@ -28,40 +28,40 @@ import Data.Tuple (Tuple(..))
 import Foreign.Object as FO
 
 decodeIdentity
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (Identity a)
+  -> Either (JsonDecodeError' customErr) (Identity a)
 decodeIdentity decoder json = Identity <$> decoder json
 
 decodeMaybe
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (Maybe a)
+  -> Either (JsonDecodeError' customErr) (Maybe a)
 decodeMaybe decoder json
   | isNull json = pure Nothing
   | otherwise = Just <$> decoder json
 
 decodeTuple
-  :: forall a b
-   . (Json -> Either JsonDecodeError a)
-  -> (Json -> Either JsonDecodeError b)
+  :: forall customErr a b
+   . (Json -> Either (JsonDecodeError' customErr) a)
+  -> (Json -> Either (JsonDecodeError' customErr) b)
   -> Json
-  -> Either JsonDecodeError (Tuple a b)
+  -> Either (JsonDecodeError' customErr) (Tuple a b)
 decodeTuple decoderA decoderB json = decodeArray Right json >>= f
   where
-  f :: Array Json -> Either JsonDecodeError (Tuple a b)
+  f :: Array Json -> Either (JsonDecodeError' customErr) (Tuple a b)
   f = case _ of
     [ a, b ] -> Tuple <$> decoderA a <*> decoderB b
     _ -> Left $ TypeMismatch "Tuple"
 
 decodeEither
-  :: forall a b
-   . (Json -> Either JsonDecodeError a)
-  -> (Json -> Either JsonDecodeError b)
+  :: forall customErr a b
+   . (Json -> Either (JsonDecodeError' customErr) a)
+  -> (Json -> Either (JsonDecodeError' customErr) b)
   -> Json
-  -> Either JsonDecodeError (Either a b)
+  -> Either (JsonDecodeError' customErr) (Either a b)
 decodeEither decoderA decoderB json =
   lmap (Named "Either") $ decodeJObject json >>= \obj -> do
     tag <- note (AtKey "tag" MissingValue) $ FO.lookup "tag" obj
@@ -71,31 +71,31 @@ decodeEither decoderA decoderB json =
       Just "Left" -> Left <$> decoderA val
       _ -> Left $ AtKey "tag" (UnexpectedValue tag)
 
-decodeNull :: Json -> Either JsonDecodeError Unit
+decodeNull :: forall customErr. Json -> Either (JsonDecodeError' customErr) Unit
 decodeNull = caseJsonNull (Left $ TypeMismatch "null") (const $ Right unit)
 
-decodeBoolean :: Json -> Either JsonDecodeError Boolean
+decodeBoolean :: forall customErr. Json -> Either (JsonDecodeError' customErr) Boolean
 decodeBoolean = caseJsonBoolean (Left $ TypeMismatch "Boolean") Right
 
-decodeNumber :: Json -> Either JsonDecodeError Number
+decodeNumber :: forall customErr. Json -> Either (JsonDecodeError' customErr) Number
 decodeNumber = caseJsonNumber (Left $ TypeMismatch "Number") Right
 
-decodeInt :: Json -> Either JsonDecodeError Int
+decodeInt :: forall customErr. Json -> Either (JsonDecodeError' customErr) Int
 decodeInt = note (TypeMismatch "Integer") <<< fromNumber <=< decodeNumber
 
-decodeString :: Json -> Either JsonDecodeError String
+decodeString :: forall customErr. Json -> Either (JsonDecodeError' customErr) String
 decodeString = caseJsonString (Left $ TypeMismatch "String") Right
 
-decodeNonEmptyString :: Json -> Either JsonDecodeError NonEmptyString
+decodeNonEmptyString :: forall customErr. Json -> Either (JsonDecodeError' customErr) NonEmptyString
 decodeNonEmptyString json =
   note (Named "NonEmptyString" $ UnexpectedValue json)
     =<< map (NonEmptyString.fromString) (decodeString json)
 
 decodeNonEmpty_Array
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (NonEmpty Array a)
+  -> Either (JsonDecodeError' customErr) (NonEmpty Array a)
 decodeNonEmpty_Array decoder =
   lmap (Named "NonEmpty Array")
     <<< traverse decoder
@@ -105,10 +105,10 @@ decodeNonEmpty_Array decoder =
     <=< decodeJArray
 
 decodeNonEmptyArray
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (NonEmptyArray a)
+  -> Either (JsonDecodeError' customErr) (NonEmptyArray a)
 decodeNonEmptyArray decoder =
   lmap (Named "NonEmptyArray")
     <<< traverse decoder
@@ -118,10 +118,10 @@ decodeNonEmptyArray decoder =
     <=< decodeJArray
 
 decodeNonEmpty_List
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (NonEmpty List a)
+  -> Either (JsonDecodeError' customErr) (NonEmpty List a)
 decodeNonEmpty_List decoder =
   lmap (Named "NonEmpty List")
     <<< traverse decoder
@@ -131,10 +131,10 @@ decodeNonEmpty_List decoder =
     <=< map (map fromFoldable) decodeJArray
 
 decodeNonEmptyList
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (NonEmptyList a)
+  -> Either (JsonDecodeError' customErr) (NonEmptyList a)
 decodeNonEmptyList decoder =
   lmap (Named "NonEmptyList")
     <<< traverse decoder
@@ -143,76 +143,76 @@ decodeNonEmptyList decoder =
       <<< L.uncons
     <=< map (map fromFoldable) decodeJArray
 
-decodeCodePoint :: Json -> Either JsonDecodeError CodePoint
+decodeCodePoint :: forall customErr. Json -> Either (JsonDecodeError' customErr) CodePoint
 decodeCodePoint json =
   note (Named "CodePoint" $ UnexpectedValue json)
     =<< map (codePointAt 0) (decodeString json)
 
 decodeForeignObject
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (FO.Object a)
+  -> Either (JsonDecodeError' customErr) (FO.Object a)
 decodeForeignObject decoder =
   lmap (Named "ForeignObject")
     <<< traverse decoder
     <=< decodeJObject
 
 decodeArray
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (Array a)
+  -> Either (JsonDecodeError' customErr) (Array a)
 decodeArray decoder =
   lmap (Named "Array")
     <<< traverseWithIndex (\i -> lmap (AtIndex i) <<< decoder)
     <=< decodeJArray
 
 decodeList
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (List a)
+  -> Either (JsonDecodeError' customErr) (List a)
 decodeList decoder =
   lmap (Named "List")
     <<< traverse decoder
     <=< map (map fromFoldable) decodeJArray
 
 decodeSet
-  :: forall a
+  :: forall customErr a
    . Ord a
-  => (Json -> Either JsonDecodeError a)
+  => (Json -> Either (JsonDecodeError' customErr) a)
   -> Json
-  -> Either JsonDecodeError (S.Set a)
+  -> Either (JsonDecodeError' customErr) (S.Set a)
 decodeSet decoder =
   map (S.fromFoldable :: List a -> S.Set a) <<< decodeList decoder
 
 decodeMap
-  :: forall a b
+  :: forall customErr a b
    . Ord a
-  => (Json -> Either JsonDecodeError a)
-  -> (Json -> Either JsonDecodeError b)
+  => (Json -> Either (JsonDecodeError' customErr) a)
+  -> (Json -> Either (JsonDecodeError' customErr) b)
   -> Json
-  -> Either JsonDecodeError (M.Map a b)
+  -> Either (JsonDecodeError' customErr) (M.Map a b)
 decodeMap decoderA decoderB =
   map (M.fromFoldable :: List (Tuple a b) -> M.Map a b)
     <<< decodeList (decodeTuple decoderA decoderB)
 
-decodeVoid :: Json -> Either JsonDecodeError Void
+decodeVoid :: forall customErr. Json -> Either (JsonDecodeError' customErr) Void
 decodeVoid _ = Left $ UnexpectedValue $ fromString "Value cannot be Void"
 
-decodeJArray :: Json -> Either JsonDecodeError (Array Json)
+decodeJArray :: forall customErr. Json -> Either (JsonDecodeError' customErr) (Array Json)
 decodeJArray = note (TypeMismatch "Array") <<< toArray
 
-decodeJObject :: Json -> Either JsonDecodeError (FO.Object Json)
+decodeJObject :: forall customErr. Json -> Either (JsonDecodeError' customErr) (FO.Object Json)
 decodeJObject = note (TypeMismatch "Object") <<< toObject
 
 getField
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> FO.Object Json
   -> String
-  -> Either JsonDecodeError a
+  -> Either (JsonDecodeError' customErr) a
 getField decoder obj str =
   maybe
     (Left $ AtKey str MissingValue)
@@ -220,22 +220,22 @@ getField decoder obj str =
     (FO.lookup str obj)
 
 getFieldOptional
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> FO.Object Json
   -> String
-  -> Either JsonDecodeError (Maybe a)
+  -> Either (JsonDecodeError' customErr) (Maybe a)
 getFieldOptional decoder obj str =
   maybe (pure Nothing) (map Just <<< decode) (FO.lookup str obj)
   where
   decode = lmap (AtKey str) <<< decoder
 
 getFieldOptional'
-  :: forall a
-   . (Json -> Either JsonDecodeError a)
+  :: forall customErr a
+   . (Json -> Either (JsonDecodeError' customErr) a)
   -> FO.Object Json
   -> String
-  -> Either JsonDecodeError (Maybe a)
+  -> Either (JsonDecodeError' customErr) (Maybe a)
 getFieldOptional' decoder obj str =
   maybe (pure Nothing) decode (FO.lookup str obj)
   where
diff --git a/src/Data/Argonaut/Decode/Error.purs b/src/Data/Argonaut/Decode/Error.purs
index 1d4b659..23fab80 100644
--- a/src/Data/Argonaut/Decode/Error.purs
+++ b/src/Data/Argonaut/Decode/Error.purs
@@ -8,19 +8,22 @@ import Data.Argonaut.Core (Json, stringify)
 import Data.Generic.Rep (class Generic)
 
 -- | Error type for failures while decoding.
-data JsonDecodeError
+data JsonDecodeError' a
   = TypeMismatch String
   | UnexpectedValue Json
-  | AtIndex Int JsonDecodeError
-  | AtKey String JsonDecodeError
-  | Named String JsonDecodeError
+  | AtIndex Int (JsonDecodeError' a)
+  | AtKey String (JsonDecodeError' a)
+  | Named String (JsonDecodeError' a)
   | MissingValue
+  | Custom a
 
-derive instance eqJsonDecodeError :: Eq JsonDecodeError
-derive instance ordJsonDecodeError :: Ord JsonDecodeError
-derive instance genericJsonDecodeError :: Generic JsonDecodeError _
+type JsonDecodeError = JsonDecodeError' Void
 
-instance showJsonDecodeError :: Show JsonDecodeError where
+derive instance eqJsonDecodeError :: Eq a => Eq (JsonDecodeError' a)
+derive instance ordJsonDecodeError :: Ord a => Ord (JsonDecodeError' a)
+derive instance genericJsonDecodeError :: Generic (JsonDecodeError' a) _
+
+instance showJsonDecodeError :: Show a => Show (JsonDecodeError' a) where
   show = case _ of
     TypeMismatch s -> "(TypeMismatch " <> show s <> ")"
     UnexpectedValue j -> "(UnexpectedValue " <> stringify j <> ")"
@@ -28,10 +31,14 @@ instance showJsonDecodeError :: Show JsonDecodeError where
     AtKey k e -> "(AtKey " <> show k <> " " <> show e <> ")"
     Named s e -> "(Named " <> show s <> " " <> show e <> ")"
     MissingValue -> "MissingValue"
+    Custom a -> "(Custom" <> show a <> ")"
 
 -- | Prints a `JsonDecodeError` as a readable error message.
 printJsonDecodeError :: JsonDecodeError -> String
-printJsonDecodeError err =
+printJsonDecodeError = printJsonDecodeError' absurd
+
+printJsonDecodeError' :: forall a. (a -> String) -> JsonDecodeError' a -> String
+printJsonDecodeError' printCustomCtor err =
   "An error occurred while decoding a JSON value:\n" <> go err
   where
   go = case _ of
@@ -41,3 +48,4 @@ printJsonDecodeError err =
     AtKey key inner -> "  At object key \'" <> key <> "\':\n" <> go inner
     Named name inner -> "  Under '" <> name <> "':\n" <> go inner
     MissingValue -> "  No value was found."
+    Custom a -> printCustomCtor a
diff --git a/src/Data/Argonaut/Decode/Parser.purs b/src/Data/Argonaut/Decode/Parser.purs
index 30dcad3..88e0fbb 100644
--- a/src/Data/Argonaut/Decode/Parser.purs
+++ b/src/Data/Argonaut/Decode/Parser.purs
@@ -3,12 +3,12 @@ module Data.Argonaut.Decode.Parser where
 import Prelude
 
 import Data.Argonaut.Core (Json)
-import Data.Argonaut.Decode.Error (JsonDecodeError(..))
+import Data.Argonaut.Decode.Error (JsonDecodeError'(..))
 import Data.Argonaut.Parser (jsonParser)
 import Data.Bifunctor (lmap)
 import Data.Either (Either)
 
 -- | Attempt to parse a string as `Json`, failing with a typed error if the
 -- | JSON string is malformed.
-parseJson :: String -> Either JsonDecodeError Json
+parseJson :: forall customErr. String -> Either (JsonDecodeError' customErr) Json
 parseJson = lmap (\_ -> TypeMismatch "JSON") <<< jsonParser