git.iko.soy/rowtype-yoga/purescript-yoga-json
on main help sign in
Initial commit
c7f5537Mark Eibes
.github/workflows/ci.ymlnew file+37
compare with main
unifiedsplit
@@ -0,0 +1,37 @@
1+name: CI
2+
3+on:
4+ push:
5+ branches: [main]
6+ pull_request:
7+ branches: [main]
8+
9+jobs:
10+ build:
11+ runs-on: ubuntu-latest
12+ steps:
13+ - uses: actions/checkout@v2
14+
15+ - uses: purescript-contrib/setup-purescript@main
16+
17+ - uses: actions/setup-node@v2
18+ with:
19+ node-version: "14"
20+
21+ - name: Cache PureScript dependencies
22+ uses: actions/cache@v2
23+ # This cache uses the .dhall files to know when it should reinstall
24+ # and rebuild packages. It caches both the installed packages from
25+ # the `.spago` directory and compilation artifacts from the `output`
26+ # directory. When restored the compiler will rebuild any files that
27+ # have changed. If you do not want to cache compiled output, remove
28+ # the `output` path.
29+ with:
30+ key: ${{ runner.os }}-spago-${{ hashFiles('**/*.dhall') }}
31+ path: |
32+ .spago
33+ output
34+
35+ - run: spago build
36+
37+ - run: spago -x test.dhall test --no-install
.gitignorenew file+8
@@ -0,0 +1,8 @@
1+/bower_components/
2+/node_modules/
3+/output/
4+/.psc-package/
5+/.psc*
6+/.purs*
7+/.psa*
8+/.spago/
.tidyrc.jsonnew file+10
@@ -0,0 +1,10 @@
1+{
2+ "importSort": "source",
3+ "importWrap": "source",
4+ "indent": 2,
5+ "operatorsFile": null,
6+ "ribbon": 1,
7+ "typeArrowPlacement": "last",
8+ "unicode": "always",
9+ "width": 80
10+}
LICENCE/simple-json.LICENSEnew file+21
@@ -0,0 +1,21 @@
1+The MIT License (MIT)
2+
3+Copyright (c) 2017 Justin Woo
4+
5+Permission is hereby granted, free of charge, to any person obtaining a copy
6+of this software and associated documentation files (the "Software"), to deal
7+in the Software without restriction, including without limitation the rights
8+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+copies of the Software, and to permit persons to whom the Software is
10+furnished to do so, subject to the following conditions:
11+
12+The above copyright notice and this permission notice shall be included in all
13+copies or substantial portions of the Software.
14+
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+SOFTWARE.
LICENSEnew file+21
@@ -0,0 +1,21 @@
1+The MIT License (MIT)
2+
3+Copyright (c) 2022 Mark Eibes
4+
5+Permission is hereby granted, free of charge, to any person obtaining a copy
6+of this software and associated documentation files (the "Software"), to deal
7+in the Software without restriction, including without limitation the rights
8+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+copies of the Software, and to permit persons to whom the Software is
10+furnished to do so, subject to the following conditions:
11+
12+The above copyright notice and this permission notice shall be included in all
13+copies or substantial portions of the Software.
14+
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+SOFTWARE.
README.mdnew file+3
@@ -0,0 +1,3 @@
1+# purescript-json
2+
3+**Note**: This is a fork [simple-json](https://github.com/justinwoo/purescript-simple-json)([MIT Licence](./LICENSE/simple-json.LICENSE)).
bower.jsonnew file+28
@@ -0,0 +1,28 @@
1+{
2+ "name": "purescript-json",
3+ "license": "MIT",
4+ "repository": {
5+ "type": "git",
6+ "url": "git://github.com/rowtype-yoga/purescript-json.git"
7+ },
8+ "ignore": [
9+ "**/.*",
10+ "node_modules",
11+ "bower_components",
12+ "output"
13+ ],
14+ "dependencies": {
15+ "purescript-prelude": "^6.0.0",
16+ "purescript-typelevel-prelude": "^7.0.0",
17+ "purescript-record": "^4.0.0",
18+ "purescript-variant": "^8.0.0",
19+ "purescript-nullable": "^6.0.0",
20+ "purescript-foreign-object": "^4.0.0",
21+ "purescript-foreign": "^7.0.0",
22+ "purescript-exceptions": "^6.0.0",
23+ "purescript-arrays": "^7.0.0"
24+ },
25+ "devDependencies": {
26+ "purescript-assert": "^6.0.0"
27+ }
28+}
packages.dhallnew file+5
@@ -0,0 +1,5 @@
1+let upstream =
2+ https://github.com/purescript/package-sets/releases/download/psc-0.15.0-20220509/packages.dhall
3+ sha256:d4c1a03606efdbb7bb7745a9d3aa908cb1ba5611921373659a4c7bf1c41c106c
4+
5+in upstream
spago.dhallnew file+27
@@ -0,0 +1,27 @@
1+{ name = "purescript-json"
2+, dependencies =
3+ [ "arrays"
4+ , "bifunctors"
5+ , "console"
6+ , "control"
7+ , "effect"
8+ , "either"
9+ , "exceptions"
10+ , "foldable-traversable"
11+ , "foreign"
12+ , "foreign-object"
13+ , "identity"
14+ , "lists"
15+ , "maybe"
16+ , "nonempty"
17+ , "nullable"
18+ , "partial"
19+ , "prelude"
20+ , "record"
21+ , "transformers"
22+ , "typelevel-prelude"
23+ , "variant"
24+ ]
25+, packages = ./packages.dhall
26+, sources = [ "src/**/*.purs" ]
27+}
src/JSON.jsnew file+5
@@ -0,0 +1,5 @@
1+export const _parseJSON = JSON.parse;
2+
3+export const _undefined = undefined;
4+
5+export const _unsafeStringify = JSON.stringify;
src/JSON.pursnew file+394
@@ -0,0 +1,394 @@
1+module JSON
2+( E
3+, readJSON
4+, readJSON'
5+, readJSON_
6+, writeJSON
7+, write
8+, read
9+, read'
10+, read_
11+, parseJSON
12+, undefined
13+, unsafeStringify
14+
15+, class ReadForeign
16+, readImpl
17+, class ReadForeignFields
18+, getFields
19+, class ReadForeignVariant
20+, readVariantImpl
21+
22+, class WriteForeign
23+, writeImpl
24+, class WriteForeignFields
25+, writeImplFields
26+, class WriteForeignVariant
27+, writeVariantImpl
28+
29+) where
30+
31+import Prelude
32+
33+import Control.Alt ((<|>))
34+import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT, withExcept)
35+import Data.Array.NonEmpty (NonEmptyArray, fromArray, toArray)
36+import Data.Bifunctor (lmap)
37+import Data.Either (Either(..), hush, note)
38+import Data.Identity (Identity(..))
39+import Data.List.NonEmpty (singleton)
40+import Data.Maybe (Maybe(..), maybe)
41+import Data.Nullable (Nullable, toMaybe, toNullable)
42+import Data.Symbol (class IsSymbol, reflectSymbol)
43+import Data.Traversable (sequence, traverse)
44+import Data.TraversableWithIndex (traverseWithIndex)
45+import Data.Variant (Variant, inj, on)
46+import Effect.Exception (message, try)
47+import Effect.Uncurried as EU
48+import Effect.Unsafe (unsafePerformEffect)
49+import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
50+import Foreign.Index (readProp)
51+import Foreign.Object (Object)
52+import Foreign.Object as Object
53+import Partial.Unsafe (unsafeCrashWith)
54+import Prim.Row as Row
55+import Prim.RowList (class RowToList, Cons, Nil, RowList)
56+import Record (get)
57+import Record.Builder (Builder)
58+import Record.Builder as Builder
59+import Type.Prelude (Proxy(..))
60+
61+-- | An alias for the Either result of decoding
62+type E a = Either MultipleErrors a
63+
64+-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
65+-- | parsing failed.
66+readJSON :: forall a
67+ . ReadForeign a
68+ => String
69+ -> E a
70+readJSON = runExcept <<< (readImpl <=< parseJSON)
71+
72+-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
73+readJSON' :: forall a
74+ . ReadForeign a
75+ => String
76+ -> F a
77+readJSON' = readImpl <=< parseJSON
78+
79+-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
80+-- | failed.
81+readJSON_ :: forall a
82+ . ReadForeign a
83+ => String
84+ -> Maybe a
85+readJSON_ = hush <<< readJSON
86+
87+-- | JSON.stringify
88+foreign import _unsafeStringify :: forall a. a -> String
89+
90+unsafeStringify :: forall a. a -> String
91+unsafeStringify = _unsafeStringify
92+
93+-- | Write a JSON string from a type `a`.
94+writeJSON :: forall a
95+ . WriteForeign a
96+ => a
97+ -> String
98+writeJSON = _unsafeStringify <<< writeImpl
99+
100+write :: forall a
101+ . WriteForeign a
102+ => a
103+ -> Foreign
104+write = writeImpl
105+
106+-- | Read a Foreign value to a type
107+read :: forall a
108+ . ReadForeign a
109+ => Foreign
110+ -> E a
111+read = runExcept <<< readImpl
112+
113+-- | Read a value of any type as Foreign to a type
114+readAsForeign :: forall a b
115+ . ReadForeign a
116+ => b
117+ -> E a
118+readAsForeign = read <<< unsafeToForeign
119+
120+read' :: forall a
121+ . ReadForeign a
122+ => Foreign
123+ -> F a
124+read' = readImpl
125+
126+-- | Read a Foreign value to a type, as a Maybe of type
127+read_ :: forall a
128+ . ReadForeign a
129+ => Foreign
130+ -> Maybe a
131+read_ = hush <<< read
132+
133+foreign import _parseJSON :: EU.EffectFn1 String Foreign
134+
135+parseJSON :: String -> F Foreign
136+parseJSON
137+ = ExceptT
138+ <<< Identity
139+ <<< lmap (pure <<< ForeignError <<< message)
140+ <<< runPure
141+ <<< try
142+ <<< EU.runEffectFn1 _parseJSON
143+ where
144+ -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
145+ runPure = unsafePerformEffect
146+
147+foreign import _undefined :: Foreign
148+
149+undefined :: Foreign
150+undefined = _undefined
151+
152+-- | A class for reading foreign values to a type
153+class ReadForeign a where
154+ readImpl :: Foreign -> F a
155+
156+instance readForeign :: ReadForeign Foreign where
157+ readImpl = pure
158+
159+instance readChar :: ReadForeign Char where
160+ readImpl = readChar
161+
162+instance readNumber :: ReadForeign Number where
163+ readImpl = readNumber
164+
165+instance readInt :: ReadForeign Int where
166+ readImpl = readInt
167+
168+instance readString :: ReadForeign String where
169+ readImpl = readString
170+
171+instance readBoolean :: ReadForeign Boolean where
172+ readImpl = readBoolean
173+
174+instance readArray :: ReadForeign a => ReadForeign (Array a) where
175+ readImpl = traverseWithIndex readAtIdx <=< readArray
176+ where
177+ readAtIdx i f = withExcept (map (ErrorAtIndex i)) (readImpl f)
178+
179+instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
180+ readImpl = readNullOrUndefined readImpl
181+ where
182+ readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
183+ readNullOrUndefined f value = Just <$> f value
184+
185+instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
186+ readImpl o = withExcept (map reformat) $
187+ map toNullable <$> traverse readImpl =<< readNull o
188+ where
189+ reformat error = case error of
190+ TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
191+ _ -> error
192+
193+instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
194+ readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
195+ where
196+ readObject' :: Foreign -> F (Object Foreign)
197+ readObject' value
198+ | tagOf value == "Object" = pure $ unsafeFromForeign value
199+ | otherwise = fail $ TypeMismatch "Object" (tagOf value)
200+
201+
202+instance readRecord ::
203+ ( RowToList fields fieldList
204+ , ReadForeignFields fieldList () fields
205+ ) => ReadForeign (Record fields) where
206+ readImpl o = flip Builder.build {} <$> getFields fieldListP o
207+ where
208+ fieldListP = Proxy :: Proxy fieldList
209+
210+-- | A class for reading foreign values from properties
211+class ReadForeignFields (xs :: RowList Type) (from :: Row Type) (to :: Row Type)
212+ | xs -> from to where
213+ getFields :: Proxy xs
214+ -> Foreign
215+ -> F (Builder (Record from) (Record to))
216+
217+instance readFieldsCons ::
218+ ( IsSymbol name
219+ , ReadForeign ty
220+ , ReadForeignFields tail from from'
221+ , Row.Lacks name from'
222+ , Row.Cons name ty from' to
223+ ) => ReadForeignFields (Cons name ty tail) from to where
224+ getFields _ obj = (compose <$> first) `exceptTApply` rest
225+ where
226+ first = do
227+ value <- withExcept' (readImpl =<< readProp name obj)
228+ pure $ Builder.insert nameP value
229+ rest = getFields tailP obj
230+ nameP = Proxy :: Proxy name
231+ tailP = Proxy :: Proxy tail
232+ name = reflectSymbol nameP
233+ withExcept' = withExcept <<< map $ ErrorAtProperty name
234+
235+exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
236+exceptTApply fun a = ExceptT $ applyEither
237+ <$> runExceptT fun
238+ <*> runExceptT a
239+
240+applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
241+applyEither (Left e) (Right _) = Left e
242+applyEither (Left e1) (Left e2) = Left (e1 <> e2)
243+applyEither (Right _) (Left e) = Left e
244+applyEither (Right fun) (Right a) = Right (fun a)
245+
246+instance readFieldsNil ::
247+ ReadForeignFields Nil () () where
248+ getFields _ _ =
249+ pure identity
250+
251+instance readForeignVariant ::
252+ ( RowToList variants rl
253+ , ReadForeignVariant rl variants
254+ ) => ReadForeign (Variant variants) where
255+ readImpl o = readVariantImpl (Proxy :: Proxy rl) o
256+
257+class ReadForeignVariant (xs :: RowList Type) (row :: Row Type)
258+ | xs -> row where
259+ readVariantImpl :: Proxy xs
260+ -> Foreign
261+ -> F (Variant row)
262+
263+instance readVariantNil ::
264+ ReadForeignVariant Nil trash where
265+ readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."
266+
267+instance readVariantCons ::
268+ ( IsSymbol name
269+ , ReadForeign ty
270+ , Row.Cons name ty trash row
271+ , ReadForeignVariant tail row
272+ ) => ReadForeignVariant (Cons name ty tail) row where
273+ readVariantImpl _ o = do
274+ obj :: { type :: String, value :: Foreign } <- readImpl o
275+ if obj.type == name
276+ then do
277+ value :: ty <- readImpl obj.value
278+ pure $ inj namep value
279+ else
280+ (fail <<< ForeignError $ "Did not match variant tag " <> name)
281+ <|> readVariantImpl (Proxy :: Proxy tail) o
282+ where
283+ namep = Proxy :: Proxy name
284+ name = reflectSymbol namep
285+
286+-- -- | A class for writing a value into JSON
287+-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
288+class WriteForeign a where
289+ writeImpl :: a -> Foreign
290+
291+instance WriteForeign Foreign where
292+ writeImpl = identity
293+
294+instance WriteForeign String where
295+ writeImpl = unsafeToForeign
296+
297+instance WriteForeign Int where
298+ writeImpl = unsafeToForeign
299+
300+instance WriteForeign Char where
301+ writeImpl = unsafeToForeign
302+
303+instance WriteForeign Number where
304+ writeImpl = unsafeToForeign
305+
306+instance WriteForeign Boolean where
307+ writeImpl = unsafeToForeign
308+
309+instance WriteForeign a => WriteForeign (Array a) where
310+ writeImpl xs = unsafeToForeign $ writeImpl <$> xs
311+
312+instance WriteForeign a => WriteForeign (Maybe a) where
313+ writeImpl = maybe undefined writeImpl
314+
315+instance WriteForeign a => WriteForeign (Nullable a) where
316+ writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe
317+
318+instance WriteForeign a => WriteForeign (Object.Object a) where
319+ writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)
320+
321+instance
322+ ( RowToList row rl
323+ , WriteForeignFields rl row () to
324+ ) => WriteForeign (Record row) where
325+ writeImpl rec = unsafeToForeign $ Builder.build steps {}
326+ where
327+ rlp = Proxy :: Proxy rl
328+ steps = writeImplFields rlp rec
329+
330+class WriteForeignFields (rl :: RowList Type) row (from :: Row Type) (to :: Row Type)
331+ | rl -> row from to where
332+ writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)
333+
334+instance
335+ ( IsSymbol name
336+ , WriteForeign ty
337+ , WriteForeignFields tail row from from'
338+ , Row.Cons name ty whatever row
339+ , Row.Lacks name from'
340+ , Row.Cons name Foreign from' to
341+ ) => WriteForeignFields (Cons name ty tail) row from to where
342+ writeImplFields _ rec = result
343+ where
344+ namep = Proxy :: Proxy name
345+ value = writeImpl $ get namep rec
346+ tailp = Proxy :: Proxy tail
347+ rest = writeImplFields tailp rec
348+ result = Builder.insert namep value <<< rest
349+instance
350+ WriteForeignFields Nil row () () where
351+ writeImplFields _ _ = identity
352+
353+instance
354+ ( RowToList row rl
355+ , WriteForeignVariant rl row
356+ ) => WriteForeign (Variant row) where
357+ writeImpl variant = writeVariantImpl (Proxy :: Proxy rl) variant
358+
359+class WriteForeignVariant (rl :: RowList Type) (row :: Row Type)
360+ | rl -> row where
361+ writeVariantImpl :: forall g. g rl -> Variant row -> Foreign
362+
363+instance
364+ WriteForeignVariant Nil () where
365+ writeVariantImpl _ _ =
366+ -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
367+ unsafeCrashWith "Variant was not able to be writen row WriteForeign."
368+
369+instance
370+ ( IsSymbol name
371+ , WriteForeign ty
372+ , Row.Cons name ty subRow row
373+ , WriteForeignVariant tail subRow
374+ ) => WriteForeignVariant (Cons name ty tail) row where
375+ writeVariantImpl _ variant =
376+ on
377+ namep
378+ writeVariant
379+ (writeVariantImpl (Proxy :: Proxy tail))
380+ variant
381+ where
382+ namep = Proxy :: Proxy name
383+ writeVariant value = unsafeToForeign
384+ { type: reflectSymbol namep
385+ , value: writeImpl value
386+ }
387+
388+instance ReadForeign a => ReadForeign (NonEmptyArray a) where
389+ readImpl f = do
390+ raw :: Array a <- readImpl f
391+ except $ note (singleton $ ForeignError "Nonempty array expected, got empty array") $ fromArray raw
392+
393+instance writeForeignNEArray :: WriteForeign a => WriteForeign (NonEmptyArray a) where
394+ writeImpl a = writeImpl <<< toArray $ a
test.dhallnew file+9
@@ -0,0 +1,9 @@
1+let conf = ./spago.dhall
2+
3+in conf
4+ // { sources = conf.sources # [ "test/**/*.purs" ]
5+ , dependencies =
6+ conf.dependencies
7+ # [ "assert"
8+ ]
9+ }
test/EnumSumGeneric.pursnew file+66
@@ -0,0 +1,66 @@
1+module Test.EnumSumGeneric where
2+
3+import Prelude
4+
5+import Control.Alt ((<|>))
6+import Control.Monad.Except (throwError)
7+import Data.Either (Either, isRight)
8+import Data.Generic.Rep (class Generic, Constructor(..), NoArguments(..), Sum(..), to)
9+import Data.Show.Generic (genericShow)
10+import Effect (Effect)
11+import Foreign (Foreign)
12+import Foreign as Foreign
13+import JSON as JSON
14+import Test.Assert (assert)
15+import Type.Prelude (class IsSymbol, Proxy(..), reflectSymbol)
16+
17+enumReadForeign :: forall a rep
18+ . Generic a rep
19+ => EnumReadForeign rep
20+ => Foreign
21+ -> Foreign.F a
22+enumReadForeign f =
23+ to <$> enumReadForeignImpl f
24+
25+-- type class for "enums", or nullary sum types
26+class EnumReadForeign rep where
27+ enumReadForeignImpl :: Foreign -> Foreign.F rep
28+
29+instance
30+ ( EnumReadForeign a
31+ , EnumReadForeign b
32+ ) => EnumReadForeign (Sum a b) where
33+ enumReadForeignImpl f
34+ = Inl <$> enumReadForeignImpl f
35+ <|> Inr <$> enumReadForeignImpl f
36+
37+instance
38+ ( IsSymbol name
39+ ) => EnumReadForeign (Constructor name NoArguments) where
40+ enumReadForeignImpl f = do
41+ s <- JSON.readImpl f
42+ if s == name
43+ then pure $ Constructor NoArguments
44+ else throwError <<< pure <<< Foreign.ForeignError $
45+ "Enum string " <> s <> " did not match expected string " <> name
46+ where
47+ name = reflectSymbol (Proxy :: Proxy name)
48+
49+data Fruit
50+ = Abogado
51+ | Boat
52+ | Candy
53+derive instance Generic Fruit _
54+instance JSON.ReadForeign Fruit where
55+ readImpl = enumReadForeign
56+instance Show Fruit where
57+ show = genericShow
58+
59+readFruit :: String -> Either Foreign.MultipleErrors Fruit
60+readFruit = JSON.readJSON
61+
62+main :: Effect Unit
63+main = do
64+ assert <<< isRight $ readFruit "\"Abogado\""
65+ assert <<< isRight $ readFruit "\"Boat\""
66+ assert <<< isRight $ readFruit "\"Candy\""
test/Generic.pursnew file+69
@@ -0,0 +1,69 @@
1+module Test.Generic where
2+
3+import Prelude
4+
5+import Control.Alt ((<|>))
6+import Data.Either (Either, isRight)
7+import Data.Generic.Rep as GR
8+import Data.Show.Generic (genericShow)
9+import Effect (Effect)
10+import Foreign (Foreign)
11+import Foreign as Foreign
12+import JSON as JSON
13+import Test.Assert (assert)
14+
15+data IntOrBoolean
16+ = Int Int
17+ | Boolean Boolean
18+instance readForeign :: JSON.ReadForeign IntOrBoolean where
19+ readImpl f
20+ = Int <$> Foreign.readInt f
21+ <|> Boolean <$> Foreign.readBoolean f
22+instance showIntOrBoolean :: Show IntOrBoolean where
23+ show (Int i) = "(Int " <> show i <> ")"
24+ show (Boolean i) = "(Boolean " <> show i <> ")"
25+
26+decodeToIntOrBoolean :: String -> Either Foreign.MultipleErrors IntOrBoolean
27+decodeToIntOrBoolean = JSON.readJSON
28+
29+data IntOrBoolean2
30+ = Int2 Int
31+ | Boolean2 Boolean
32+
33+derive instance genericIntOrBoolean2 :: GR.Generic IntOrBoolean2 _
34+
35+instance showIntOrBoolean2 :: Show IntOrBoolean2 where
36+ show = genericShow
37+instance readForeignIntOrBoolean2 :: JSON.ReadForeign IntOrBoolean2 where
38+ readImpl f = GR.to <$> untaggedSumRep f
39+
40+class UntaggedSumRep rep where
41+ untaggedSumRep :: Foreign -> Foreign.F rep
42+
43+instance untaggedSumRepSum ::
44+ ( UntaggedSumRep a
45+ , UntaggedSumRep b
46+ ) => UntaggedSumRep (GR.Sum a b) where
47+ untaggedSumRep f
48+ = GR.Inl <$> untaggedSumRep f
49+ <|> GR.Inr <$> untaggedSumRep f
50+
51+instance untaggedSumRepConstructor ::
52+ ( UntaggedSumRep a
53+ ) => UntaggedSumRep (GR.Constructor name a) where
54+ untaggedSumRep f = GR.Constructor <$> untaggedSumRep f
55+
56+instance untaggedSumRepArgument ::
57+ ( JSON.ReadForeign a
58+ ) => UntaggedSumRep (GR.Argument a) where
59+ untaggedSumRep f = GR.Argument <$> JSON.readImpl f
60+
61+decodeToIntOrBoolean2 :: String -> Either Foreign.MultipleErrors IntOrBoolean2
62+decodeToIntOrBoolean2 = JSON.readJSON
63+
64+main :: Effect Unit
65+main = do
66+ assert <<< isRight $ decodeToIntOrBoolean "1" -- (Right (Int 1))
67+ assert <<< isRight $ decodeToIntOrBoolean "true" -- (Right (Boolean true))
68+ assert <<< isRight $ decodeToIntOrBoolean2 "1" -- (Right (Int2 1))
69+ assert <<< isRight $ decodeToIntOrBoolean2 "true" -- (Right (Boolean2 true))
test/Inferred.pursnew file+52
@@ -0,0 +1,52 @@
1+module Test.Inferred where
2+
3+import Prelude
4+
5+import Control.Alt ((<|>))
6+import Control.Monad.Except (runExcept)
7+import Data.Either (Either(..), isRight)
8+import Effect (Effect)
9+import Foreign (Foreign)
10+import Foreign as Foreign
11+import Record as Record
12+import JSON as JSON
13+import Test.Assert (assert)
14+import Type.Prelude (Proxy(..))
15+
16+type RecordWithEither =
17+ { apple :: Int
18+ , banana :: Either Int String
19+ }
20+
21+readEitherImpl
22+ :: forall a b
23+ . JSON.ReadForeign a
24+ => JSON.ReadForeign b
25+ => Foreign
26+ -> Foreign.F (Either a b)
27+readEitherImpl f
28+ = Left <$> JSON.readImpl f
29+ <|> Right <$> JSON.readImpl f
30+
31+readRecordWithEitherJSON :: String -> Either Foreign.MultipleErrors RecordWithEither
32+readRecordWithEitherJSON s = runExcept do
33+ inter <- JSON.readJSON' s
34+ banana <- readEitherImpl inter.banana
35+ pure $ inter { banana = banana }
36+
37+type RecordMisnamedField =
38+ { cherry :: Int
39+ }
40+
41+readRecordMisnamedField :: String -> Either Foreign.MultipleErrors RecordMisnamedField
42+readRecordMisnamedField s = do
43+ inter <- JSON.readJSON s
44+ pure $ Record.rename grapeP cherryP inter
45+ where
46+ grapeP = Proxy :: Proxy "grape"
47+ cherryP = Proxy :: Proxy "cherry"
48+
49+main :: Effect Unit
50+main = do
51+ assert <<< isRight $ readRecordWithEitherJSON """{"apple": 1, "banana": 1}"""
52+ assert <<< isRight $ readRecordWithEitherJSON """{"apple": 1, "banana": "yellow"}"""
test/Main.pursnew file+156
@@ -0,0 +1,156 @@
1+module Test.Main where
2+
3+import Prelude
4+
5+import Control.Monad.Except (runExcept)
6+import Data.Bifunctor (lmap)
7+import Data.Either (Either(..), either, isRight)
8+import Data.List (List(..), (:))
9+import Data.List.NonEmpty (NonEmptyList(..))
10+import Data.Maybe (Maybe)
11+import Data.NonEmpty (NonEmpty(..))
12+import Data.Nullable (Nullable)
13+import Data.Variant (Variant)
14+import Effect (Effect)
15+import Effect.Exception (throw)
16+import Foreign (Foreign, ForeignError(..), MultipleErrors)
17+import Foreign.Object (Object)
18+import JSON (class ReadForeign, class WriteForeign, parseJSON, readJSON, writeJSON)
19+import Test.Assert (assertEqual)
20+import Test.EnumSumGeneric as Test.EnumSumGeneric
21+import Test.Generic as Test.Generic
22+import Test.Inferred as Test.Inferred
23+import Test.Quickstart as Test.Quickstart
24+import Type.Proxy (Proxy(..))
25+
26+type E a = Either MultipleErrors a
27+
28+type MyTest =
29+ { a :: Int
30+ , b :: String
31+ , c :: Boolean
32+ , d :: Array String
33+ }
34+
35+type MyTestNull =
36+ { a :: Int
37+ , b :: String
38+ , c :: Boolean
39+ , d :: Array String
40+ , e :: Maybe (Array String)
41+ }
42+
43+type MyTestStrMap =
44+ { a :: Int
45+ , b :: Object Int
46+ }
47+
48+type MyTestMaybe =
49+ { a :: Maybe String
50+ }
51+
52+type MyTestManyMaybe =
53+ { a :: Maybe String
54+ , aNull :: Maybe String
55+ , b :: Maybe Int
56+ , bNull :: Maybe Int
57+ , c :: Maybe Boolean
58+ , cNull :: Maybe Boolean
59+ , d :: Maybe Number
60+ , dNull :: Maybe Number
61+ , e :: Maybe (Array (Maybe String))
62+ , eNull :: Maybe (Array (Maybe String))
63+ }
64+
65+type MyTestNullable =
66+ { a :: Nullable String
67+ , b :: Nullable String
68+ }
69+
70+type MyTestVariant = Variant
71+ ( a :: String
72+ , b :: Int
73+ )
74+
75+roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Effect Unit
76+roundtrips _ enc0 = do
77+ let parseJSON' = lmap show <<< runExcept <<< parseJSON
78+ dec0 :: E a
79+ dec0 = readJSON enc0
80+ enc1 = either (const "bad1") writeJSON dec0
81+ json0 :: Either String Foreign
82+ json0 = parseJSON' enc0
83+ json1 :: Either String Foreign
84+ json1 = parseJSON' enc1
85+ dec1 :: E a
86+ dec1 = readJSON enc1
87+ enc2 = either (const "bad2") writeJSON dec1
88+ when (enc1 /= enc2) $ throw enc0
89+
90+shouldEqual :: forall a . Eq a => Show a => a -> a -> Effect Unit
91+shouldEqual a b =
92+ assertEqual { actual: a, expected: b}
93+
94+main :: Effect Unit
95+main = do
96+ shouldEqual 1 1
97+
98+ -- "fails with invalid JSON"
99+ let r1 = readJSON """{ "c": 1, "d": 2}"""
100+ r1 `shouldEqual`
101+ (Left (NonEmptyList (NonEmpty (ErrorAtProperty "a" (TypeMismatch "Int" "Undefined")) ((ErrorAtProperty "b" (TypeMismatch "String" "Undefined")) : (ErrorAtProperty "c" (TypeMismatch "Boolean" "Number")) : (ErrorAtProperty "d" (TypeMismatch "array" "Number")) : Nil))))
102+ isRight (r1 :: E MyTest) `shouldEqual` false
103+
104+ -- "works with missing Maybe fields by setting them to Nothing"
105+ let r2 = readJSON "{}"
106+ (writeJSON <$> (r2 :: E MyTestMaybe)) `shouldEqual` (Right """{}""")
107+
108+ -- "fails with undefined for null with correct error message"
109+ let r3 = readJSON """
110+ { "a": "asdf" }
111+ """
112+ r3 `shouldEqual`
113+ (Left (NonEmptyList (NonEmpty (ErrorAtProperty "b" (TypeMismatch "Nullable String" "Undefined")) Nil)))
114+ (isRight (r3 :: E MyTestNullable)) `shouldEqual` false
115+
116+ -- roundtrips
117+ -- "works with proper JSON"
118+ roundtrips (Proxy :: Proxy MyTest) """
119+ { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
120+ """
121+
122+ -- "works with JSON lacking Maybe field"
123+ roundtrips (Proxy :: Proxy MyTestNull) """
124+ { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
125+ """
126+
127+ -- "works with JSON containing Maybe field"
128+ roundtrips (Proxy :: Proxy MyTestNull) """
129+ { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
130+ """
131+
132+ -- -- "works with JSON containing Object field"
133+ roundtrips (Proxy :: Proxy MyTestStrMap) """
134+ { "a": 1, "b": {"asdf": 1, "c": 2} }
135+ """
136+
137+ -- "works with Maybe field and existing value"
138+ roundtrips (Proxy :: Proxy MyTestMaybe) """
139+ { "a": "foo" }
140+ """
141+
142+ -- "works with Nullable"
143+ roundtrips (Proxy :: Proxy MyTestNullable) """
144+ { "a": null, "b": "a" }
145+ """
146+
147+ -- "works with Variant"
148+ roundtrips (Proxy :: Proxy MyTestVariant) """
149+ { "type": "b", "value": 123 }
150+ """
151+
152+ -- run examples
153+ Test.Generic.main
154+ Test.EnumSumGeneric.main
155+ Test.Inferred.main
156+ Test.Quickstart.main
test/QuickStart.pursnew file+130
@@ -0,0 +1,130 @@
1+module Test.Quickstart where
2+
3+import Prelude
4+
5+import Data.Array as Array
6+import Data.Either (Either(..))
7+import Data.Maybe (Maybe(..))
8+import Data.Nullable (Nullable, toNullable)
9+import Effect (Effect)
10+import Effect.Class.Console (log)
11+import Foreign (ForeignError(..))
12+import JSON as JSON
13+import Test.Assert (assertEqual)
14+
15+type MyRecordAlias =
16+ { apple :: String
17+ , banana :: Array Int
18+ }
19+
20+testJSON1 :: String
21+testJSON1 = """
22+{ "apple": "Hello"
23+, "banana": [ 1, 2, 3 ]
24+}
25+"""
26+
27+testJSON2 :: String
28+testJSON2 = """
29+{ "apple": false
30+, "banana": [ 1, 2, 3 ]
31+}
32+"""
33+
34+type WithMaybe =
35+ { cherry :: Maybe Boolean
36+ }
37+
38+testJSON3 :: String
39+testJSON3 = """
40+{ "cherry": true
41+}
42+"""
43+
44+testJSON4 :: String
45+testJSON4 = """
46+{}
47+"""
48+
49+type WithNullable =
50+ { cherry :: Nullable Boolean
51+ }
52+
53+newtype FancyInt = FancyInt Int
54+derive newtype instance eqFancyInt :: Eq FancyInt
55+derive newtype instance showFancyInt :: Show FancyInt
56+derive newtype instance readForeignFancyInt :: JSON.ReadForeign FancyInt
57+derive newtype instance writeForeignFancyInt :: JSON.WriteForeign FancyInt
58+
59+main :: Effect Unit
60+main = do
61+ case JSON.readJSON testJSON1 of
62+ Right (r :: MyRecordAlias) -> do
63+ assertEqual { expected: r.apple, actual: "Hello"}
64+ assertEqual { expected: r.banana, actual: [ 1, 2, 3 ] }
65+ Left e -> do
66+ assertEqual { expected: "failed", actual: show e }
67+
68+ case JSON.readJSON testJSON2 of
69+ Right (r :: MyRecordAlias) -> do
70+ assertEqual { expected: "failed", actual: show r }
71+ Left e -> do
72+ let errors = Array.fromFoldable e
73+ assertEqual { expected: [ErrorAtProperty "apple" (TypeMismatch "String" "Boolean")], actual: errors }
74+
75+ let
76+ myValue =
77+ { apple: "Hi"
78+ , banana: [ 1, 2, 3 ]
79+ } :: MyRecordAlias
80+
81+ log (JSON.writeJSON myValue) -- {"banana":[1,2,3],"apple":"Hi"}
82+
83+ case JSON.readJSON testJSON3 of
84+ Right (r :: WithMaybe) -> do
85+ assertEqual { expected: Just true, actual: r.cherry }
86+ Left e -> do
87+ assertEqual { expected: "failed", actual: show e }
88+
89+ case JSON.readJSON testJSON4 of
90+ Right (r :: WithMaybe) -> do
91+ assertEqual { expected: Nothing, actual: r.cherry }
92+ Left e -> do
93+ assertEqual { expected: "failed", actual: show e }
94+
95+ let
96+ withJust =
97+ { cherry: Just true
98+ } :: WithMaybe
99+ withNothing =
100+ { cherry: Nothing
101+ } :: WithMaybe
102+
103+ log (JSON.writeJSON withJust) -- {"cherry":true}
104+ log (JSON.writeJSON withNothing) -- {}
105+
106+ case JSON.readJSON testJSON3 of
107+ Right (r :: WithNullable) -> do
108+ assertEqual { expected: toNullable (Just true), actual: r.cherry }
109+ Left e -> do
110+ assertEqual { expected: "failed", actual: show e }
111+
112+ case JSON.readJSON testJSON4 of
113+ Right (r :: WithNullable) -> do
114+ assertEqual { expected: "failed", actual: show r }
115+ Left e -> do
116+ let errors = Array.fromFoldable e
117+ assertEqual { expected: [ErrorAtProperty "cherry" (TypeMismatch "Nullable Boolean" "Undefined")], actual: errors }
118+
119+ let
120+ withNullable =
121+ { cherry: toNullable Nothing
122+ } :: WithNullable
123+ log (JSON.writeJSON withNullable) -- {"cherry":null}
124+
125+ case JSON.readJSON "1" of
126+ Right fancyInt@(FancyInt i) -> do
127+ assertEqual { expected: FancyInt 1, actual: fancyInt }
128+ assertEqual { expected: 1, actual: i }
129+ Left e -> do
130+ assertEqual { expected: "failed", actual: show e }
test/Util.pursnew file+36
@@ -0,0 +1,36 @@
1+module Test.Util where
2+
3+import Prelude
4+
5+import Prim.Row as Row
6+import Prim.RowList (class RowToList, Cons, Nil, RowList)
7+import Record (get)
8+import Type.Prelude (class IsSymbol, Proxy(..))
9+
10+-- | Check two records of the same type for equality.
11+equal
12+ :: forall r rs
13+ . RowToList r rs
14+ => EqualFields rs r
15+ => Record r
16+ -> Record r
17+ -> Boolean
18+equal a b = equalFields (Proxy :: Proxy rs) a b
19+
20+class EqualFields (rs :: RowList Type) (row :: Row Type) | rs -> row where
21+ equalFields :: Proxy rs -> Record row -> Record row -> Boolean
22+
23+instance equalFieldsCons
24+ ::
25+ ( IsSymbol name
26+ , Eq ty
27+ , Row.Cons name ty tailRow row
28+ , EqualFields tail row
29+ ) => EqualFields (Cons name ty tail) row where
30+ equalFields _ a b = get' a == get' b && rest
31+ where
32+ get' = get (Proxy :: Proxy name)
33+ rest = equalFields (Proxy :: Proxy tail) a b
34+
35+instance equalFieldsNil :: EqualFields Nil row where
36+ equalFields _ _ _ = true