Add instances for Tuple

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

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