ee26711 · rowtype-yoga/purescript-yoga-json

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

on main help sign in

Merge pull request #1 from rowtype-yoga/tuples

ee26711Mark Eibes4 years ago

.vscode/settings.jsonnew file+3

compare with main

unifiedsplit

@@ -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 @@

21 , "prelude"

22 , "record"

23 , "transformers"

24+ , "tuples"

24 , "typelevel-prelude"

25 , "typelevel-prelude"

25 , "variant"

26 , "variant"

26 ]

27 ]

src/Yoga/JSON.purs+84−20

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

18 , getFields

19 , class ReadForeignVariant

20 , readVariantImpl

21+ , class ReadTuple

22+ , readTupleImpl

23+ , tupleSize

22 , class WriteForeign

25 , class WriteForeign

23 , writeImpl

26 , writeImpl

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

31import Prelude

34import Prelude

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

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

37+import Control.Apply (lift2)

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

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

39+import Data.Array as Array

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

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

36import Data.Bifunctor (lmap)

41import Data.Bifunctor (lmap)

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

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

38import Data.Identity (Identity(..))

43import Data.Identity (Identity(..))

39import Data.List.NonEmpty (singleton)

44import Data.List.NonEmpty (singleton)

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

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

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

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

42import Data.Symbol (class IsSymbol, reflectSymbol)

47import Data.Symbol (class IsSymbol, reflectSymbol)

43import Data.Traversable (sequence, traverse)

48import Data.Traversable (sequence, traverse)

44import Data.TraversableWithIndex (traverseWithIndex)

49import Data.TraversableWithIndex (traverseWithIndex)

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

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

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

46import Effect.Exception (message, try)

52import Effect.Exception (message, try)

47import Effect.Uncurried as EU

53import Effect.Uncurried as EU

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

153class ReadForeign a where

159class ReadForeign a where

154 readImpl ∷ Foreign → F a

160 readImpl ∷ Foreign → F a

155

161

156−instance readForeign ∷ ReadForeign Foreign where

162+instance ReadForeign Foreign where

157 readImpl = pure

163 readImpl = pure

158

164

159−instance readChar ∷ ReadForeign Char where

165+instance ReadForeign Char where

160 readImpl = readChar

166 readImpl = readChar

161

167

162−instance readNumber ∷ ReadForeign Number where

168+instance ReadForeign Number where

163 readImpl = readNumber

169 readImpl = readNumber

164

170

165−instance readInt ∷ ReadForeign Int where

171+instance ReadForeign Int where

166 readImpl = readInt

172 readImpl = readInt

167

173

168−instance readString ∷ ReadForeign String where

174+instance ReadForeign String where

169 readImpl = readString

175 readImpl = readString

170

176

171−instance readBoolean ∷ ReadForeign Boolean where

177+instance ReadForeign Boolean where

172 readImpl = readBoolean

178 readImpl = readBoolean

173

179

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

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

175 readImpl = traverseWithIndex readAtIdx <=< readArray

181 readImpl = traverseWithIndex readAtIdx <=< readArray

176− where

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

178

182

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

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

180 readImpl = readNullOrUndefined readImpl

184 readImpl = readNullOrUndefined readImpl

181 where

185 where

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

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

183 Nothing

187 Nothing

184 readNullOrUndefined f value = Just <$> f value

188 readNullOrUndefined f value = Just <$> f value

185

189

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

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

187 readImpl o = withExcept (map reformat) $

191 readImpl o = withExcept (map reformat) $

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

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

189 where

193 where

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

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

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

192 _ → error

196 _ → error

193

197

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

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

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

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

196 where

200 where

197 readObject' ∷ Foreign → F (Object Foreign)

201 readObject' ∷ Foreign → F (Object Foreign)

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

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

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

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

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

201

205

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

203 ( RowToList fields fieldList

250 ( RowToList fields fieldList

204 , ReadForeignFields fieldList () fields

251 , ReadForeignFields fieldList () fields

205 ) ⇒

252 ) ⇒

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

217 Foreign →

264 Foreign →

218 F (Builder (Record from) (Record to))

265 F (Builder (Record from) (Record to))

219

266

220−instance readFieldsCons ∷

267+instance

221 ( IsSymbol name

268 ( IsSymbol name

222 , ReadForeign ty

269 , ReadForeign ty

223 , ReadForeignFields tail from from'

270 , ReadForeignFields tail from from'

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

236 name = reflectSymbol nameP

283 name = reflectSymbol nameP

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

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

238

285

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

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

288+

239exceptTApply ∷

289exceptTApply ∷

240 ∀ a b e m.

290 ∀ a b e m.

241 Semigroup e ⇒

291 Semigroup e ⇒

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

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

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

254applyEither (Right fun) (Right a) = Right (fun a)

304applyEither (Right fun) (Right a) = Right (fun a)

255

305

256−instance readFieldsNil ∷

306+instance

257 ReadForeignFields Nil () () where

307 ReadForeignFields Nil () () where

258 getFields _ _ =

308 getFields _ _ =

259 pure identity

309 pure identity

260

310

261−instance readForeignVariant ∷

311+instance

262 ( RowToList variants rl

312 ( RowToList variants rl

263 , ReadForeignVariant rl variants

313 , ReadForeignVariant rl variants

264 ) ⇒

314 ) ⇒

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

273 Foreign →

323 Foreign →

274 F (Variant row)

324 F (Variant row)

275

325

276−instance readVariantNil ∷

326+instance

277 ReadForeignVariant Nil trash where

327 ReadForeignVariant Nil trash where

278 readVariantImpl _ _ = fail $ ForeignError

328 readVariantImpl _ _ = fail $ ForeignError

279 "Unable to match any variant member."

329 "Unable to match any variant member."

280

330

281−instance readVariantCons ∷

331+instance

282 ( IsSymbol name

332 ( IsSymbol name

283 , ReadForeign ty

333 , ReadForeign ty

284 , Row.Cons name ty trash row

334 , Row.Cons name ty trash row

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

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

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

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

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

335

385

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+

336instance

400instance

337 ( RowToList row rl

401 ( RowToList row rl

338 , WriteForeignFields rl row () to

402 , WriteForeignFields rl row () to

test/Main.purs+38−4

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

3import Prelude

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

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

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

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

8import Data.Maybe (Maybe)

9import Data.NonEmpty (NonEmpty(..))

10import Data.Nullable (Nullable)

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

11import Data.Variant (Variant)

12import Data.Variant (Variant)

12import Effect (Effect)

13import Effect (Effect)

13import Effect.Exception (throw)

14import Effect.Exception (throw)

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

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

15import Foreign.Object (Object)

16import Foreign.Object (Object)

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

17+import Partial.Unsafe (unsafePartial)

17import Test.Assert (assertEqual)

18import Test.Assert (assertEqual)

18import Test.EnumSumGeneric as Test.EnumSumGeneric

19import Test.EnumSumGeneric as Test.EnumSumGeneric

19import Test.Generic as Test.Generic

20import Test.Generic as Test.Generic

20import Test.Inferred as Test.Inferred

21import Test.Inferred as Test.Inferred

21import Test.Quickstart as Test.Quickstart

22import Test.Quickstart as Test.Quickstart

22import Type.Proxy (Proxy(..))

23import Type.Proxy (Proxy(..))

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

24type E a = Either MultipleErrors a

26type E a = Either MultipleErrors a

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

70 , b ∷ Int

72 , b ∷ Int

71 )

73 )

73−roundtrips ∷

75+type MyTestTuple =

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

77+

78+

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

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

75roundtrips _ enc0 = do

80roundtrips _ enc0 = do

76 let

81 let

77 dec0 ∷ E a

82 dec0 ∷ E a

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

130 )

135 )

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

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

132

137

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+

133 -- roundtrips

163 -- roundtrips

134 -- "works with proper JSON"

164 -- "works with proper JSON"

135 roundtrips (Proxy ∷ Proxy MyTest)

165 roundtrips (Proxy ∷ Proxy MyTest)

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

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

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

174 """

204 """

175

205

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

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

208+ """

209+

176 -- run examples

210 -- run examples

177 Test.Generic.main

211 Test.Generic.main

178 Test.EnumSumGeneric.main

212 Test.EnumSumGeneric.main