ee26711 · rowtype-yoga/purescript-yoga-json

git.iko.soy/rowtype-yoga/purescript-yoga-json

Merge pull request #1 from rowtype-yoga/tuples

Add tuples by (@ursi)

commitee26711677557c0cd68076e7b94015906a65adff authorMark Eibes <mark.eibes@gmail.com> dateMon 6 Jun 2022, 09:01 (4 years ago) parent0617502 bbf06d5

4 files changed+126−24

compare with main

unifiedsplit

.vscode/settings.json+3 spago.dhall+1 src/Yoga/JSON.purs+84−20 test/Main.purs+38−4

.vscode/settings.jsonnew file+3

@@ -0,0 +1,3 @@

1+{

2+ "purescript.buildCommand": "spago -x test.dhall build -- --purs-args --json-errors"

3+}

spago.dhall+1

@@ -21,6 +21,7 @@

2121 , "prelude"

2222 , "record"

2323 , "transformers"

24+ , "tuples"

2425 , "typelevel-prelude"

2526 , "variant"

2627 ]

src/Yoga/JSON.purs+84−20

@@ -18,6 +18,9 @@ module Yoga.JSON

1818 , getFields

1919 , class ReadForeignVariant

2020 , readVariantImpl

21+ , class ReadTuple

22+ , readTupleImpl

23+ , tupleSize

2124

2225 , class WriteForeign

2326 , writeImpl

@@ -31,17 +34,20 @@ module Yoga.JSON

3134import Prelude

3235

3336import Control.Alt ((<|>))

34−import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, withExcept)

37+import Control.Apply (lift2)

38+import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, throwError, withExcept)

39+import Data.Array as Array

3540import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray)

3641import Data.Bifunctor (lmap)

3742import Data.Either (Either(..), hush, note)

3843import Data.Identity (Identity(..))

3944import Data.List.NonEmpty (singleton)

40−import Data.Maybe (Maybe(..), maybe)

45+import Data.Maybe (Maybe(..), fromMaybe, maybe)

4146import Data.Nullable (Nullable, toMaybe, toNullable)

4247import Data.Symbol (class IsSymbol, reflectSymbol)

4348import Data.Traversable (sequence, traverse)

4449import Data.TraversableWithIndex (traverseWithIndex)

50+import Data.Tuple (Tuple(..))

4551import Data.Variant (Variant, inj, on)

4652import Effect.Exception (message, try)

4753import Effect.Uncurried as EU

@@ -153,37 +159,35 @@ undefined = _undefined

153159class ReadForeign a where

154160 readImpl ∷ Foreign → F a

155161

156−instance readForeign ∷ ReadForeign Foreign where

162+instance ReadForeign Foreign where

157163 readImpl = pure

158164

159−instance readChar ∷ ReadForeign Char where

165+instance ReadForeign Char where

160166 readImpl = readChar

161167

162−instance readNumber ∷ ReadForeign Number where

168+instance ReadForeign Number where

163169 readImpl = readNumber

164170

165−instance readInt ∷ ReadForeign Int where

171+instance ReadForeign Int where

166172 readImpl = readInt

167173

168−instance readString ∷ ReadForeign String where

174+instance ReadForeign String where

169175 readImpl = readString

170176

171−instance readBoolean ∷ ReadForeign Boolean where

177+instance ReadForeign Boolean where

172178 readImpl = readBoolean

173179

174−instance readArray ∷ ReadForeign a ⇒ ReadForeign (Array a) where

180+instance ReadForeign a ⇒ ReadForeign (Array a) where

175181 readImpl = traverseWithIndex readAtIdx <=< readArray

176− where

177− readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)

178182

179−instance readMaybe ∷ ReadForeign a ⇒ ReadForeign (Maybe a) where

183+instance ReadForeign a ⇒ ReadForeign (Maybe a) where

180184 readImpl = readNullOrUndefined readImpl

181185 where

182186 readNullOrUndefined _ value | isNull value || isUndefined value = pure

183187 Nothing

184188 readNullOrUndefined f value = Just <$> f value

185189

186−instance readNullable ∷ ReadForeign a ⇒ ReadForeign (Nullable a) where

190+instance ReadForeign a ⇒ ReadForeign (Nullable a) where

187191 readImpl o = withExcept (map reformat) $

188192 map toNullable <$> traverse readImpl =<< readNull o

189193 where

@@ -191,7 +195,7 @@ instance readNullable ∷ ReadForeign a ⇒ ReadForeign (Nullable a) where

191195 TypeMismatch inner other → TypeMismatch ("Nullable " <> inner) other

192196 _ → error

193197

194−instance readObject ∷ ReadForeign a ⇒ ReadForeign (Object.Object a) where

198+instance ReadForeign a ⇒ ReadForeign (Object.Object a) where

195199 readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'

196200 where

197201 readObject' ∷ Foreign → F (Object Foreign)

@@ -199,7 +203,50 @@ instance readObject ∷ ReadForeign a ⇒ ReadForeign (Object.Object a) where

199203 | tagOf value == "Object" = pure $ unsafeFromForeign value

200204 | otherwise = fail $ TypeMismatch "Object" (tagOf value)

201205

202−instance readRecord ∷

206+instance ReadTuple (Tuple a b) ⇒ ReadForeign (Tuple a b) where

207+ readImpl = readTupleImpl 0

208+

209+-- | A class for reading JSON arrays of lenth `n` as nested tuples of size `n`

210+class ReadTuple a where

211+ readTupleImpl ∷ Int → Foreign → F a

212+ tupleSize ∷ Proxy a → Int

213+

214+instance

215+ ( ReadForeign a

216+ , ReadTuple (Tuple b c)

217+ ) ⇒

218+ ReadTuple (Tuple a (Tuple b c)) where

219+ readTupleImpl n =

220+ readImpl

221+ >=> case _ of

222+ arr → case Array.uncons arr of

223+ Just { head, tail } →

224+ lift2 Tuple

225+ (readAtIdx n head)

226+ (readTupleImpl (n + 1) $ writeImpl tail)

227+ _ → throwError $ pure $ TypeMismatch

228+ ( "array of length " <> show

229+ (1 + n + tupleSize (Proxy ∷ Proxy (Tuple b c)))

230+ )

231+ ("array of length " <> show n)

232+ tupleSize _ = 1 + tupleSize (Proxy ∷ Proxy (Tuple b c))

233+else instance readTupleHelper ∷

234+ ( ReadForeign a

235+ , ReadForeign b

236+ ) ⇒

237+ ReadTuple (Tuple a b) where

238+ readTupleImpl n =

239+ readImpl

240+ >=> case _ of

241+ [ a, b ] →

242+ lift2 Tuple (readAtIdx n a) (readAtIdx (n + 1) b)

243+ arr → throwError $ pure $ TypeMismatch

244+ ("array of length " <> show (n + 2))

245+ ("array of length " <> show (n + Array.length arr))

246+

247+ tupleSize = const 2

248+

249+instance

203250 ( RowToList fields fieldList

204251 , ReadForeignFields fieldList () fields

205252 ) ⇒

@@ -217,7 +264,7 @@ class

217264 Foreign →

218265 F (Builder (Record from) (Record to))

219266

220−instance readFieldsCons ∷

267+instance

221268 ( IsSymbol name

222269 , ReadForeign ty

223270 , ReadForeignFields tail from from'

@@ -236,6 +283,9 @@ instance readFieldsCons ∷

236283 name = reflectSymbol nameP

237284 withExcept' = withExcept <<< map $ ErrorAtProperty name

238285

286+readAtIdx ∷ ∀ a. ReadForeign a ⇒ Int → Foreign → F a

287+readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)

288+

239289exceptTApply ∷

240290 ∀ a b e m.

241291 Semigroup e ⇒

@@ -253,12 +303,12 @@ applyEither (Left e1) (Left e2) = Left (e1 <> e2)

253303applyEither (Right _) (Left e) = Left e

254304applyEither (Right fun) (Right a) = Right (fun a)

255305

256−instance readFieldsNil ∷

306+instance

257307 ReadForeignFields Nil () () where

258308 getFields _ _ =

259309 pure identity

260310

261−instance readForeignVariant ∷

311+instance

262312 ( RowToList variants rl

263313 , ReadForeignVariant rl variants

264314 ) ⇒

@@ -273,12 +323,12 @@ class

273323 Foreign →

274324 F (Variant row)

275325

276−instance readVariantNil ∷

326+instance

277327 ReadForeignVariant Nil trash where

278328 readVariantImpl _ _ = fail $ ForeignError

279329 "Unable to match any variant member."

280330

281−instance readVariantCons ∷

331+instance

282332 ( IsSymbol name

283333 , ReadForeign ty

284334 , Row.Cons name ty trash row

@@ -333,6 +383,20 @@ instance WriteForeign a ⇒ WriteForeign (Nullable a) where

333383instance WriteForeign a ⇒ WriteForeign (Object.Object a) where

334384 writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

335385

386+instance

387+ ( WriteForeign a

388+ , WriteForeign (Tuple b c)

389+ ) ⇒

390+ WriteForeign (Tuple a (Tuple b c)) where

391+ writeImpl (Tuple a bc) =

392+ writeImpl bc

393+ # read_

394+ # fromMaybe []

395+ # Array.cons (writeImpl a)

396+ # writeImpl

397+else instance (WriteForeign a, WriteForeign b) ⇒ WriteForeign (Tuple a b) where

398+ writeImpl (Tuple a b) = writeImpl [ writeImpl a, writeImpl b ]

399+

336400instance

337401 ( RowToList row rl

338402 , WriteForeignFields rl row () to

test/Main.purs+38−4

@@ -2,24 +2,26 @@ module Test.Main where

33import Prelude

5−import Data.Either (Either(..), either, isRight)

5+import Data.Either (Either(..), either, fromLeft, isRight)

66import Data.List (List(..), (:))

77import Data.List.NonEmpty (NonEmptyList(..))

88import Data.Maybe (Maybe)

99import Data.NonEmpty (NonEmpty(..))

1010import Data.Nullable (Nullable)

11+import Data.Tuple.Nested (type (/\))

1112import Data.Variant (Variant)

1213import Effect (Effect)

1314import Effect.Exception (throw)

1415import Foreign (ForeignError(..), MultipleErrors)

1516import Foreign.Object (Object)

16−import Yoga.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)

17+import Partial.Unsafe (unsafePartial)

1718import Test.Assert (assertEqual)

1819import Test.EnumSumGeneric as Test.EnumSumGeneric

1920import Test.Generic as Test.Generic

2021import Test.Inferred as Test.Inferred

2122import Test.Quickstart as Test.Quickstart

2223import Type.Proxy (Proxy(..))

24+import Yoga.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)

2325

2426type E a = Either MultipleErrors a

2527

@@ -70,8 +72,11 @@ type MyTestVariant = Variant

7072 , b ∷ Int

7173 )

7274

73−roundtrips ∷

74− ∀ a. ReadForeign a ⇒ WriteForeign a ⇒ Proxy a → String → Effect Unit

75+type MyTestTuple =

76+ Int /\ String /\ Boolean /\ Char /\ Array (Int /\ String)

77+

78+

79+roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Effect Unit

7580roundtrips _ enc0 = do

7681 let

7782 dec0 ∷ E a

@@ -130,6 +135,31 @@ main = do

130135 )

131136 (isRight (r3 ∷ E MyTestNullable)) `shouldEqual` false

132137

138+ let r4 = readJSON """[ 1, "test", 1, "a", [ 1 ] ]"""

139+ r4 `shouldEqual`

140+ (Left (NonEmptyList (NonEmpty (ErrorAtIndex 2 (TypeMismatch "Boolean" "Number")) Nil)))

141+ isRight (r4 :: E MyTestTuple) `shouldEqual` false

142+

143+ let r5 = readJSON """ [ 1, "test", true, "a", [ 1 ], null ] """

144+ r5 `shouldEqual`

145+ (Left (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 6") Nil)))

146+ isRight (r5 :: E MyTestTuple) `shouldEqual` false

147+

148+ let r6 = readJSON """ [ 1, "test", true, "a" ] """

149+ r6 `shouldEqual`

150+ (Left(NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 4") Nil)))

151+ isRight (r6 :: E MyTestTuple) `shouldEqual` false

152+

153+ let r7 = readJSON """ [ 1 ] """

154+ r7 `shouldEqual`

155+ (Left(NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 1") Nil)))

156+ isRight (r7 :: E MyTestTuple) `shouldEqual` false

157+

158+ let r8 = readJSON """ [] """

159+ r8 `shouldEqual`

160+ (Left (NonEmptyList (NonEmpty (TypeMismatch "array of length 5" "array of length 0") Nil)))

161+ isRight (r8 :: E MyTestTuple) `shouldEqual` false

162+

133163 -- roundtrips

134164 -- "works with proper JSON"

135165 roundtrips (Proxy ∷ Proxy MyTest)

@@ -173,6 +203,10 @@ main = do

173203 { "type": "b", "value": 123 }

174204 """

175205

206+ roundtrips (Proxy :: Proxy MyTestTuple) """

207+ [ 1, "test", true, "a", [ [1, "heinz"], [893, "dembowski"] ] ]

208+ """

209+

176210 -- run examples

177211 Test.Generic.main

178212 Test.EnumSumGeneric.main