/
DecodeLiberal.purs
111 lines (94 loc) · 4.15 KB
/
DecodeLiberal.purs
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
module GraphQL.Hasura.DecodeLiberal where
import Prelude
import Control.Alt ((<|>))
import Data.Argonaut.Core (Json, toObject)
import Data.Argonaut.Decode (JsonDecodeError(..), decodeJson)
import Data.Argonaut.Decode.Decoders (decodeJArray)
import Data.Array (mapMaybe)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), hush)
import Data.Maybe (Maybe(..), maybe)
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Traversable (traverse)
import Foreign.Object (Object)
import Foreign.Object as Object
import GraphQL.Hasura.Decode (class DecodeHasura, decodeHasura)
import Prim.Row as Row
import Prim.RowList as RL
import Record as Record
import StringParser (Parser)
import StringParser as P
import Type.Proxy (Proxy(..))
type DecodeLiberalOptions
= { strict :: Boolean }
-- | Decode json, with silent errors when possible
class DecodeHasuraLiberal a where
decodeHasuraLiberalImpl :: DecodeLiberalOptions -> Json -> Either JsonDecodeError a
decodeLiberal :: forall a. DecodeHasuraLiberal a => Json -> Either JsonDecodeError a
decodeLiberal = decodeHasuraLiberalImpl { strict: false }
decodeStrict :: forall a. DecodeHasuraLiberal a => Json -> Either JsonDecodeError a
decodeStrict = decodeHasuraLiberalImpl { strict: true }
instance decodeHasuraLiberalImplArray :: DecodeHasuraLiberal a => DecodeHasuraLiberal (Array a) where
decodeHasuraLiberalImpl opts j =
if opts.strict then
strict j
else
liberal j
where
liberal = decodeJArray >>> map (mapMaybe (decodeHasuraLiberalImpl opts >>> hush))
strict json = decodeJArray json >>= traverse (decodeHasuraLiberalImpl opts)
else instance decodeHasuraLiberalImplMaybe :: DecodeHasuraLiberal a => DecodeHasuraLiberal (Maybe a) where
decodeHasuraLiberalImpl opts j =
if opts.strict then
strict j
else
liberal j
where
liberal json = (Just <$> decodeHasuraLiberalImpl opts json) <|> pure Nothing
strict = decodeJson >=> traverse (decodeHasuraLiberalImpl opts)
else instance decodeRecord ::
( DecodeHasuraLiberalFields row list
, RL.RowToList row list
) =>
DecodeHasuraLiberal (Record row) where
decodeHasuraLiberalImpl opts json = case toObject json of
Just object -> decodeHasuraLiberalImplFields opts object (Proxy :: Proxy list)
Nothing -> Left $ TypeMismatch "Object"
else instance decodeOther :: DecodeHasura a => DecodeHasuraLiberal a where
decodeHasuraLiberalImpl _ = decodeHasura
class DecodeHasuraLiberalFields (row :: Row Type) (list :: RL.RowList Type) | list -> row where
decodeHasuraLiberalImplFields :: forall proxy. DecodeLiberalOptions -> Object Json -> proxy list -> Either JsonDecodeError (Record row)
instance decodeHasuraLiberalImplFieldsNil :: DecodeHasuraLiberalFields () RL.Nil where
decodeHasuraLiberalImplFields _ _ _ = Right {}
instance decodeHasuraLiberalImplFieldsCons ::
( DecodeHasuraLiberalField value
, DecodeHasuraLiberalFields rowTail tail
, IsSymbol field
, Row.Cons field value rowTail row
, Row.Lacks field rowTail
) =>
DecodeHasuraLiberalFields row (RL.Cons field value tail) where
decodeHasuraLiberalImplFields opts object _ = do
let
_field = Proxy :: Proxy field
fieldName = reflectSymbol _field
fieldValue = Object.lookup fieldName object
case decodeHasuraLiberalImplField opts fieldValue of
Just fieldVal -> do
val <- lmap (AtKey fieldName) fieldVal
rest <- decodeHasuraLiberalImplFields opts object (Proxy :: Proxy tail)
Right $ Record.insert _field val rest
Nothing -> Left $ AtKey fieldName MissingValue
class DecodeHasuraLiberalField a where
decodeHasuraLiberalImplField :: DecodeLiberalOptions -> Maybe Json -> Maybe (Either JsonDecodeError a)
instance decodeFieldMaybe ::
DecodeHasuraLiberal a =>
DecodeHasuraLiberalField (Maybe a) where
decodeHasuraLiberalImplField _ Nothing = Just $ Right Nothing
decodeHasuraLiberalImplField opts (Just j) = Just $ decodeHasuraLiberalImpl opts j
else instance decodeFieldId ::
DecodeHasuraLiberal a =>
DecodeHasuraLiberalField a where
decodeHasuraLiberalImplField opts j = decodeHasuraLiberalImpl opts <$> j
maybeFail :: forall a. String -> Maybe a -> Parser a
maybeFail str = maybe (P.fail str) pure