1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
module Gargantext.Utils.SimpleJSON where
import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (withExcept)
import Data.Generic.Rep as GR
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, ForeignError(..), fail)
import Foreign as Foreign
import Foreign.Object as FO
import Simple.JSON as JSON
import Type.Prelude (class IsSymbol, SProxy(..), reflectSymbol)
taggedSumRep :: forall a rep
. GR.Generic a rep
=> GenericTaggedSumRep rep
=> Foreign
-> Foreign.F a
taggedSumRep f = GR.to <$> genericTaggedSumRep f
-- | Generic Tagged Sum Representations, with "type" as key and rest
-- of key/values representing the object. Note that this is slightly
-- difrerent than what Simple.JSON generics provides as it wrapes the
-- tag in "type" and object under "value" key.
class GenericTaggedSumRep rep where
genericTaggedSumRep :: Foreign -> Foreign.F rep
instance ( GenericTaggedSumRep a
, GenericTaggedSumRep b
) => GenericTaggedSumRep (GR.Sum a b) where
genericTaggedSumRep f
= GR.Inl <$> genericTaggedSumRep f
<|> GR.Inr <$> genericTaggedSumRep f
instance ( GenericTaggedSumRep a
, IsSymbol name
) => GenericTaggedSumRep (GR.Constructor name a) where
genericTaggedSumRep f = do
-- r :: { "type" :: String } <- JSON.read' f
-- if r."type" == name
-- then withExcept (map $ ErrorAtProperty name) $ GR.Constructor <$> genericTaggedSumRep r
-- else fail $ ForeignError $ "Wrong type tag " <> r."type" <> " where " <> name <> " was expected."
r :: FO.Object Foreign <- JSON.read' f
case FO.pop "type" r of
Nothing -> fail $ ForeignError $ "Key 'type' not found."
Just (Tuple name' obj) -> do
n' <- Foreign.readString name'
if n' == name
then withExcept (map $ ErrorAtProperty name) $ GR.Constructor <$> (genericTaggedSumRep $ Foreign.unsafeToForeign obj)
else fail $ ForeignError $ "Wrong type tag " <> n' <> " where " <> name <> " was expected."
where
nameP = SProxy :: SProxy name
name = reflectSymbol nameP
instance ( JSON.ReadForeign a
) => GenericTaggedSumRep (GR.Argument a) where
genericTaggedSumRep f = GR.Argument <$> JSON.readImpl f
-----------------------------------------------------------
-- | Applying Generics-Rep to decoding untagged JSON values
-- |
-- | https://purescript-simple-json.readthedocs.io/en/latest/generics-rep.html
class UntaggedSumRep rep where
untaggedSumRep :: Foreign -> Foreign.F rep
instance untaggedSumRepSum ::
( UntaggedSumRep a
, UntaggedSumRep b
) => UntaggedSumRep (GR.Sum a b) where
untaggedSumRep f
= GR.Inl <$> untaggedSumRep f
<|> GR.Inr <$> untaggedSumRep f
instance untaggedSumRepConstructor ::
( UntaggedSumRep a
) => UntaggedSumRep (GR.Constructor name a) where
untaggedSumRep f = GR.Constructor <$> untaggedSumRep f
instance untaggedSumRepArgument ::
( JSON.ReadForeign a
) => UntaggedSumRep (GR.Argument a) where
untaggedSumRep f = GR.Argument <$> JSON.readImpl f