From f9b9831c04553c67ea7c7b346b3d597ac26419ce Mon Sep 17 00:00:00 2001 From: "Thomas R. Honeyman" Date: Tue, 27 Aug 2019 21:26:40 -0700 Subject: [PATCH] add nonemptyarray and nonemptylist instances --- src/Data/Argonaut/Decode/Class.purs | 69 +++++++++++++--------- src/Data/Argonaut/Encode/Class.purs | 47 ++++++++------- test/Test/Main.purs | 88 ++++++++++++++++------------- 3 files changed, 116 insertions(+), 88 deletions(-) diff --git a/src/Data/Argonaut/Decode/Class.purs b/src/Data/Argonaut/Decode/Class.purs index f476bdd..6f08a2e 100644 --- a/src/Data/Argonaut/Decode/Class.purs +++ b/src/Data/Argonaut/Decode/Class.purs @@ -4,12 +4,16 @@ import Prelude import Data.Argonaut.Core (Json, isNull, caseJsonNull, caseJsonBoolean, caseJsonNumber, caseJsonString, toArray, toObject, toString, stringify) import Data.Array as Arr +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NEA import Data.Bifunctor (lmap, rmap) import Data.Either (Either(..), note) import Data.Identity (Identity(..)) import Data.Int (fromNumber) import Data.List (List(..), (:), fromFoldable) import Data.List as L +import Data.List.NonEmpty (NonEmptyList) +import Data.List.NonEmpty as NEL import Data.Map as M import Data.Maybe (maybe, Maybe(..)) import Data.NonEmpty (NonEmpty, (:|)) @@ -63,10 +67,10 @@ instance decodeJsonNumber :: DecodeJson Number where decodeJson = caseJsonNumber (Left "Value is not a Number") Right instance decodeJsonInt :: DecodeJson Int where - decodeJson - = maybe (Left "Value is not an integer") Right - <<< fromNumber - <=< decodeJson + decodeJson = + maybe (Left "Value is not an integer") Right + <<< fromNumber + <=< decodeJson instance decodeJsonString :: DecodeJson String where decodeJson = caseJsonString (Left "Value is not a String") Right @@ -74,15 +78,25 @@ instance decodeJsonString :: DecodeJson String where instance decodeJsonJson :: DecodeJson Json where decodeJson = Right -instance decodeJsonNonEmptyArray :: (DecodeJson a) => DecodeJson (NonEmpty Array a) where - decodeJson - = lmap ("Couldn't decode NonEmpty Array: " <> _) - <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< Arr.uncons) <=< decodeJArray) +instance decodeJsonNonEmpty_Array :: (DecodeJson a) => DecodeJson (NonEmpty Array a) where + decodeJson = + lmap ("Couldn't decode NonEmpty Array: " <> _) + <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< Arr.uncons) <=< decodeJArray) -instance decodeJsonNonEmptyList :: (DecodeJson a) => DecodeJson (NonEmpty List a) where - decodeJson - = lmap ("Couldn't decode NonEmpty List: " <> _) - <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< L.uncons) <=< map (map fromFoldable) decodeJArray) +instance decodeJsonNonEmptyArray :: (DecodeJson a) => DecodeJson (NonEmptyArray a) where + decodeJson = + lmap ("Couldn't decode NonEmptyArray: " <> _) + <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> NEA.cons' x.head x.tail) <<< note " is empty" <<< Arr.uncons) <=< decodeJArray) + +instance decodeJsonNonEmpty_List :: (DecodeJson a) => DecodeJson (NonEmpty List a) where + decodeJson = + lmap ("Couldn't decode NonEmpty List: " <> _) + <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< L.uncons) <=< map (map fromFoldable) decodeJArray) + +instance decodeJsonNonEmptyList :: (DecodeJson a) => DecodeJson (NonEmptyList a) where + decodeJson = + lmap ("Couldn't decode NonEmptyList: " <> _) + <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> NEL.cons' x.head x.tail) <<< note " is empty" <<< L.uncons) <=< map (map fromFoldable) decodeJArray) instance decodeJsonChar :: DecodeJson CodePoint where decodeJson j = @@ -90,22 +104,22 @@ instance decodeJsonChar :: DecodeJson CodePoint where =<< codePointAt 0 <$> decodeJson j instance decodeForeignObject :: DecodeJson a => DecodeJson (FO.Object a) where - decodeJson - = lmap ("Couldn't decode ForeignObject: " <> _) - <<< (traverse decodeJson <=< decodeJObject) + decodeJson = + lmap ("Couldn't decode ForeignObject: " <> _) + <<< (traverse decodeJson <=< decodeJObject) instance decodeArray :: DecodeJson a => DecodeJson (Array a) where - decodeJson - = lmap ("Couldn't decode Array (" <> _) - <<< (traverseWithIndex f <=< decodeJArray) + decodeJson = + lmap ("Couldn't decode Array (" <> _) + <<< (traverseWithIndex f <=< decodeJArray) where - msg i m = "Failed at index " <> show i <> "): " <> m - f i = lmap (msg i) <<< decodeJson + msg i m = "Failed at index " <> show i <> "): " <> m + f i = lmap (msg i) <<< decodeJson instance decodeList :: DecodeJson a => DecodeJson (List a) where - decodeJson - = lmap ("Couldn't decode List: " <> _) - <<< (traverse decodeJson <=< map (map fromFoldable) decodeJArray) + decodeJson = + lmap ("Couldn't decode List: " <> _) + <<< (traverse decodeJson <=< map (map fromFoldable) decodeJArray) instance decodeSet :: (Ord a, DecodeJson a) => DecodeJson (S.Set a) where decodeJson = map (S.fromFoldable :: List a -> S.Set a) <<< decodeJson @@ -127,7 +141,6 @@ instance decodeRecord , RL.RowToList row list ) => DecodeJson (Record row) where - decodeJson json = case toObject json of Just object -> gDecodeJson object (RLProxy :: RLProxy list) @@ -147,12 +160,12 @@ instance gDecodeJsonCons , Row.Lacks field rowTail ) => GDecodeJson row (RL.Cons field value tail) where - gDecodeJson object _ = do - let sProxy :: SProxy field - sProxy = SProxy + let + sProxy :: SProxy field + sProxy = SProxy - fieldName = reflectSymbol sProxy + fieldName = reflectSymbol sProxy rest <- gDecodeJson object (RLProxy :: RLProxy tail) diff --git a/src/Data/Argonaut/Encode/Class.purs b/src/Data/Argonaut/Encode/Class.purs index a11b274..826e6be 100644 --- a/src/Data/Argonaut/Encode/Class.purs +++ b/src/Data/Argonaut/Encode/Class.purs @@ -4,11 +4,15 @@ import Prelude import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromNumber, fromObject, fromString, jsonNull) import Data.Array as Arr +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NEA import Data.Either (Either, either) import Data.Identity (Identity(..)) import Data.Int (toNumber) import Data.List (List(..), (:), toUnfoldable) import Data.List as L +import Data.List.NonEmpty as NEL +import Data.List.Types (NonEmptyList) import Data.Map as M import Data.Maybe (Maybe(..)) import Data.NonEmpty (NonEmpty(..)) @@ -31,8 +35,9 @@ instance encodeIdentity :: EncodeJson a => EncodeJson (Identity a) where encodeJson (Identity a) = encodeJson a instance encodeJsonMaybe :: EncodeJson a => EncodeJson (Maybe a) where - encodeJson Nothing = jsonNull - encodeJson (Just a) = encodeJson a + encodeJson = case _ of + Nothing -> jsonNull + Just a -> encodeJson a instance encodeJsonTuple :: (EncodeJson a, EncodeJson b) => EncodeJson (Tuple a b) where encodeJson (Tuple a b) = encodeJson [encodeJson a, encodeJson b] @@ -42,8 +47,9 @@ instance encodeJsonEither :: (EncodeJson a, EncodeJson b) => EncodeJson (Either where obj :: forall c. EncodeJson c => String -> c -> Json obj tag x = - fromObject $ FO.fromFoldable $ - Tuple "tag" (fromString tag) : Tuple "value" (encodeJson x) : Nil + fromObject + $ FO.fromFoldable + $ Tuple "tag" (fromString tag) : Tuple "value" (encodeJson x) : Nil instance encodeJsonUnit :: EncodeJson Unit where encodeJson = const jsonNull @@ -66,17 +72,23 @@ instance encodeJsonJson :: EncodeJson Json where instance encodeJsonCodePoint :: EncodeJson CodePoint where encodeJson = encodeJson <<< CP.singleton -instance encodeJsonNonEmptyArray :: (EncodeJson a) => EncodeJson (NonEmpty Array a) where - encodeJson (NonEmpty h t) = encodeJson $ Arr.cons h t +instance encodeJsonNonEmpty_Array :: (EncodeJson a) => EncodeJson (NonEmpty Array a) where + encodeJson (NonEmpty h t) = encodeJson (Arr.cons h t) -instance encodeJsonNonEmptyList :: (EncodeJson a) => EncodeJson (NonEmpty List a) where - encodeJson (NonEmpty h t) = encodeJson $ L.insertAt 0 h t +instance encodeJsonNonEmptyArray :: (EncodeJson a) => EncodeJson (NonEmptyArray a) where + encodeJson = encodeJson <<< NEA.toArray + +instance encodeJsonNonEmpty_List :: (EncodeJson a) => EncodeJson (NonEmpty List a) where + encodeJson (NonEmpty h t) = encodeJson (L.insertAt 0 h t) + +instance encodeJsonNonEmptyList :: (EncodeJson a) => EncodeJson (NonEmptyList a) where + encodeJson = encodeJson <<< NEL.toList instance encodeJsonChar :: EncodeJson Char where encodeJson = encodeJson <<< CU.singleton instance encodeJsonArray :: EncodeJson a => EncodeJson (Array a) where - encodeJson json = fromArray (encodeJson <$> json) + encodeJson = fromArray <<< map encodeJson instance encodeJsonList :: EncodeJson a => EncodeJson (List a) where encodeJson = fromArray <<< map encodeJson <<< toUnfoldable @@ -98,7 +110,6 @@ instance encodeRecord , RL.RowToList row list ) => EncodeJson (Record row) where - encodeJson rec = fromObject $ gEncodeJson rec (RLProxy :: RLProxy list) class GEncodeJson (row :: # Type) (list :: RL.RowList) where @@ -114,13 +125,9 @@ instance gEncodeJsonCons , Row.Cons field value tail' row ) => GEncodeJson row (RL.Cons field value tail) where - - gEncodeJson row _ = - let - sProxy :: SProxy field - sProxy = SProxy - in - FO.insert - (reflectSymbol sProxy) - (encodeJson $ Record.get sProxy row) - (gEncodeJson row (RLProxy :: RLProxy tail)) + gEncodeJson row _ = do + let sProxy = SProxy :: SProxy field + FO.insert + (reflectSymbol sProxy) + (encodeJson $ Record.get sProxy row) + (gEncodeJson row (RLProxy :: RLProxy tail)) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 3a05fab..f97f6ae 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -9,11 +9,13 @@ import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:), (.:!), (.:?), ( import Data.Argonaut.Encode (encodeJson, (:=), (:=?), (~>), (~>?)) import Data.Argonaut.Gen (genJson) import Data.Argonaut.Parser (jsonParser) +import Data.Array.NonEmpty (NonEmptyArray) import Data.Bifunctor (rmap) import Data.Either (Either(..)) import Data.Foldable (foldl) import Data.List (List) import Data.List as List +import Data.List.Types (NonEmptyList) import Data.Maybe (Maybe(..), isJust, isNothing, maybe) import Data.Monoid (power) import Data.NonEmpty (NonEmpty) @@ -69,49 +71,41 @@ main = flip runReaderT 0 do suite "Manual Combinators Checks" manualRecordDecode suite "Error Message Checks" errorMsgCheck - -genTestRecord - :: Gen (Record - ( i :: Int - , n :: Number - , s :: String - )) +genTestRecord :: Gen { i :: Int, n :: Number, s :: String } genTestRecord = arbitrary encodeDecodeRecordCheck :: Test encodeDecodeRecordCheck = do test "Testing that any record can be encoded and then decoded" do - quickCheck rec_encode_then_decode + quickCheck recEncodeThenDecode where - rec_encode_then_decode :: Gen Result - rec_encode_then_decode = do + recEncodeThenDecode :: Gen Result + recEncodeThenDecode = do rec <- genTestRecord let redecoded = decodeJson (encodeJson rec) pure $ Right rec == redecoded (show redecoded <> " /= Right " <> show rec) - genTestJson :: Gen Json genTestJson = resize 5 genJson encodeDecodeCheck :: Test encodeDecodeCheck = do test "Testing that any JSON can be encoded and then decoded" do - quickCheck prop_encode_then_decode + quickCheck propEncodeThenDecode test "Testing that any JSON can be decoded and then encoded" do - quickCheck prop_decode_then_encode + quickCheck propDecodeThenEncode where - - prop_encode_then_decode :: Gen Result - prop_encode_then_decode = do + propEncodeThenDecode :: Gen Result + propEncodeThenDecode = do json <- genTestJson let redecoded = decodeJson (encodeJson json) pure $ Right json == redecoded (show (rmap stringify redecoded) <> " /= Right " <> stringify json) - prop_decode_then_encode :: Gen Result - prop_decode_then_encode = do + propDecodeThenEncode :: Gen Result + propDecodeThenEncode = do json <- genTestJson let (decoded :: Either String Json) = decodeJson json let reencoded = decoded >>= (encodeJson >>> pure) @@ -123,37 +117,35 @@ genObj = suchThat (resize 5 genJson) isObject combinatorsCheck :: Test combinatorsCheck = do test "Check assoc builder `:=`" do - quickCheck prop_assoc_builder_str + quickCheck propAssocBuilderStr test "Check assocOptional builder `:=?`" do - quickCheck prop_assoc_optional_builder_str + quickCheck propAssocOptionalBuilderStr test "Check JAssoc append `~>`" do - quickCheck prop_assoc_append + quickCheck propAssocAppend test "Check JAssoc appendOptional `~>?`" do - quickCheck prop_assoc_append_optional + quickCheck propAssocAppendOptional test "Check get field `obj .: 'foo'`" do -- this doesn't really test .: - quickCheck prop_get_jobject_field - + quickCheck propGetJObjectField where - - prop_assoc_builder_str :: Gen Result - prop_assoc_builder_str = do + propAssocBuilderStr :: Gen Result + propAssocBuilderStr = do key <- genUnicodeString str <- genUnicodeString - case (key := str) of - Tuple k json -> - pure $ Tuple key (decodeJson json) === Tuple k (Right str) + let Tuple k json = key := str + pure $ Tuple key (decodeJson json) === Tuple k (Right str) - prop_assoc_optional_builder_str :: Gen Result - prop_assoc_optional_builder_str = do + propAssocOptionalBuilderStr :: Gen Result + propAssocOptionalBuilderStr = do key <- genUnicodeString maybeStr <- genMaybe genUnicodeString - case (key :=? maybeStr) of + case key :=? maybeStr of Just (Tuple k json) -> pure $ Tuple key (decodeJson json) === Tuple k (Right maybeStr) - Nothing -> pure Success + Nothing -> + pure Success - prop_assoc_append :: Gen Result - prop_assoc_append = do + propAssocAppend :: Gen Result + propAssocAppend = do key <- genUnicodeString val <- genTestJson obj <- genObj @@ -162,8 +154,8 @@ combinatorsCheck = do Just value -> pure Success _ -> pure (Failed "failed to lookup key") - prop_assoc_append_optional :: Gen Result - prop_assoc_append_optional = do + propAssocAppendOptional :: Gen Result + propAssocAppendOptional = do key <- genUnicodeString maybeVal <- genMaybe genTestJson obj <- genObj @@ -172,8 +164,8 @@ combinatorsCheck = do Just value -> isJust maybeVal === true _ -> isNothing maybeVal === true - prop_get_jobject_field :: Gen Result - prop_get_jobject_field = do + propGetJObjectField :: Gen Result + propGetJObjectField = do obj <- genObj pure (true === maybe false go (toObject obj)) where @@ -306,6 +298,14 @@ nonEmptyCheck = do ("x = " <> show x <> ", decoded = " <> show decoded) Left err -> false err + test "Test EncodeJson/DecodeJson on NonEmptyArray" do + quickCheck \(x :: NonEmptyArray String) -> + case decodeJson (encodeJson x) of + Right decoded -> + decoded == x + ("x = " <> show x <> ", decoded = " <> show decoded) + Left err -> + false err test "Test EncodeJson/DecodeJson on NonEmpty List" do quickCheck \(x :: NonEmpty List String) -> case decodeJson (encodeJson x) of @@ -314,6 +314,14 @@ nonEmptyCheck = do ("x = " <> show x <> ", decoded = " <> show decoded) Left err -> false err + test "Test EncodeJson/DecodeJson on NonEmptyList" do + quickCheck \(x :: NonEmptyList String) -> + case decodeJson (encodeJson x) of + Right decoded -> + decoded == x + ("x = " <> show x <> ", decoded = " <> show decoded) + Left err -> + false err errorMsgCheck :: Test errorMsgCheck = do