From dc278f2a5ccfdc9fef76573167ce01855977c2c7 Mon Sep 17 00:00:00 2001 From: Mason Mackaman Date: Sun, 31 Jan 2021 18:35:22 -0500 Subject: [PATCH] Add instances for Tuple --- src/Simple/JSON.purs | 58 +++++++++++++++++++++++++++++++++++++++++--- test/Main.purs | 44 +++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+), 4 deletions(-) diff --git a/src/Simple/JSON.purs b/src/Simple/JSON.purs index 96d603d..f125ab4 100644 --- a/src/Simple/JSON.purs +++ b/src/Simple/JSON.purs @@ -13,6 +13,9 @@ module Simple.JSON , class ReadForeign , readImpl +, class ReadTuple +, readTupleImpl +, tupleSize , class ReadForeignFields , getFields , class ReadForeignVariant @@ -30,17 +33,20 @@ module Simple.JSON import Prelude import Control.Alt ((<|>)) -import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, withExcept) +import Control.Apply (lift2) +import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, throwError, withExcept) +import Data.Array as Array import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray) import Data.Bifunctor (lmap) import Data.Either (Either(..), hush, note) import Data.Identity (Identity(..)) import Data.List.NonEmpty (singleton) -import Data.Maybe (Maybe(..), maybe) +import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Nullable (Nullable, toMaybe, toNullable) import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (sequence, traverse) import Data.TraversableWithIndex (traverseWithIndex) +import Data.Tuple (Tuple(..)) import Data.Variant (Variant, inj, on) import Effect.Exception (message, try) import Effect.Uncurried as EU @@ -57,6 +63,7 @@ import Record (get) import Record.Builder (Builder) import Record.Builder as Builder import Type.Prelude (RLProxy(..)) +import Type.Proxy (Proxy(..)) -- | An alias for the Either result of decoding type E a = Either MultipleErrors a @@ -167,8 +174,6 @@ instance readBoolean :: ReadForeign Boolean where instance readArray :: ReadForeign a => ReadForeign (Array a) where readImpl = traverseWithIndex readAtIdx <=< readArray - where - readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f) instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where readImpl = readNullOrUndefined readImpl @@ -192,6 +197,38 @@ instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where | tagOf value == "Object" = pure $ unsafeFromForeign value | otherwise = fail $ TypeMismatch "Object" (tagOf value) +instance readTuple :: ReadTuple (Tuple a b) => ReadForeign (Tuple a b) where + readImpl = readTupleImpl 0 + +-- | A class for reading JSON arrays of lenth `n` as nested tuples of size `n` +class ReadTuple a where + readTupleImpl :: Int -> Foreign -> F a + tupleSize :: Proxy a -> Int + +instance readTupleNestedHelper :: (ReadForeign a, ReadTuple (Tuple b c)) => ReadTuple (Tuple a (Tuple b c)) where + readTupleImpl n = + readImpl + >=> case _ of + arr -> case Array.uncons arr of + Just { head, tail } -> + lift2 Tuple + (readAtIdx n head) + (readTupleImpl (n + 1) $ writeImpl tail) + _ -> throwError $ pure $ TypeMismatch + ("array of length " <> show (1 + n + tupleSize (Proxy :: Proxy (Tuple b c)))) + ("array of length " <> show n) + tupleSize _ = 1 + tupleSize (Proxy :: Proxy (Tuple b c)) +else instance readTupleHelper :: (ReadForeign a, ReadForeign b) => ReadTuple (Tuple a b) where + readTupleImpl n = + readImpl + >=> case _ of + [ a, b ] -> + lift2 Tuple (readAtIdx n a) (readAtIdx (n + 1) b) + arr -> throwError $ pure $ TypeMismatch + ("array of length " <> show (n + 2) ) + ("array of length " <> show (n + Array.length arr)) + + tupleSize = const 2 instance readRecord :: ( RowToList fields fieldList @@ -226,6 +263,9 @@ instance readFieldsCons :: name = reflectSymbol nameP withExcept' = withExcept <<< map $ ErrorAtProperty name +readAtIdx :: ∀ a. ReadForeign a => Int -> Foreign -> F a +readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f) + exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b exceptTApply fun a = ExceptT $ applyEither <$> runExceptT fun @@ -312,6 +352,16 @@ instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) whe instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl) +instance writeForeignTupleNested :: (WriteForeign a, WriteForeign (Tuple b c)) => WriteForeign (Tuple a (Tuple b c)) where + writeImpl (Tuple a bc) = + writeImpl bc + # read_ + # fromMaybe [] + # Array.cons (writeImpl a) + # writeImpl +else instance writeForeignTuple :: (WriteForeign a, WriteForeign b) => WriteForeign (Tuple a b) where + writeImpl (Tuple a b) = writeImpl [ writeImpl a, writeImpl b ] + instance recordWriteForeign :: ( RowToList row rl , WriteForeignFields rl row () to diff --git a/test/Main.purs b/test/Main.purs index a4d82cc..b980eaf 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmptyList(..)) import Data.Maybe (Maybe) import Data.NonEmpty (NonEmpty(..)) import Data.Nullable (Nullable) +import Data.Tuple.Nested (type (/\)) import Data.Variant (Variant) import Effect (Effect) import Effect.Exception (throw) @@ -73,6 +74,10 @@ type MyTestVariant = Variant , b :: Int ) +type MyTestTuple = + Int /\ String /\ Boolean /\ Char /\ Array Int + + roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Effect Unit roundtrips _ enc0 = do let parseJSON' = lmap show <<< runExcept <<< parseJSON @@ -114,6 +119,41 @@ main = do (NonEmptyList (NonEmpty (ErrorAtProperty "b" (TypeMismatch "Nullable String" "Undefined")) Nil)) (isRight (r3 :: E MyTestNullable)) `shouldEqual` false + let r4 = readJSON """ + [ 1, "test", 1, "a", [ 1 ] ] + """ + (unsafePartial $ fromLeft r4) `shouldEqual` + (NonEmptyList (NonEmpty (ErrorAtIndex 2 (TypeMismatch "Boolean" "Number")) Nil)) + isRight (r4 :: E MyTestTuple) `shouldEqual` false + + let r5 = readJSON """ + [ 1, "test", true, "a", [ 1 ], null ] + """ + (unsafePartial $ fromLeft r5) `shouldEqual` + (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 6") Nil)) + isRight (r5 :: E MyTestTuple) `shouldEqual` false + + let r6 = readJSON """ + [ 1, "test", true, "a" ] + """ + (unsafePartial $ fromLeft r6) `shouldEqual` + (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 4") Nil)) + isRight (r6 :: E MyTestTuple) `shouldEqual` false + + let r7 = readJSON """ + [ 1 ] + """ + (unsafePartial $ fromLeft r7) `shouldEqual` + (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 1") Nil)) + isRight (r7 :: E MyTestTuple) `shouldEqual` false + + let r8 = readJSON """ + [] + """ + (unsafePartial $ fromLeft r8) `shouldEqual` + (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 0") Nil)) + isRight (r8 :: E MyTestTuple) `shouldEqual` false + -- roundtrips -- "works with proper JSON" roundtrips (Proxy :: Proxy MyTest) """ @@ -150,6 +190,10 @@ main = do { "type": "b", "value": 123 } """ + roundtrips (Proxy :: Proxy MyTestTuple) """ + [ 1, "test", true, "a", [ 1 ] ] + """ + -- run examples Test.Generic.main Test.EnumSumGeneric.main