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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Aeson where
import Data.Aeson (Value (..))
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Error.Tree
import Data.Maybe (catMaybes)
import Data.Vector qualified as Vector
import Label
import PossehlAnalyticsPrelude
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec qualified as Hspec
-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree'
parseErrorTree :: Error -> Json.ParseError Error -> ErrorTree
parseErrorTree contextMsg errs =
errs
& Json.displayError prettyError
<&> newError
& nonEmpty
& \case
Nothing -> singleError contextMsg
Just errs' -> errorTree contextMsg errs'
-- | Parse a key from the object, à la 'Json.key', return a labelled value.
--
-- We don’t provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
-- txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" Text)
-- @@
keyLabel ::
forall label err m a.
Monad m =>
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label a)
keyLabel = do
keyLabel' (Proxy @label)
-- | Parse a key from the object, à la 'Json.key', return a labelled value.
-- Version of 'keyLabel' that requires a proxy.
--
-- @@
-- do
-- txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" Text)
-- @@
keyLabel' ::
forall label err m a.
Monad m =>
Proxy label ->
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label a)
keyLabel' Proxy key parser = label @label <$> Json.key key parser
-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
--
-- We don’t provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
-- txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay ::
forall label err m a.
Monad m =>
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label (Maybe a))
keyLabelMay = do
keyLabelMay' (Proxy @label)
-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
-- Version of 'keyLabelMay' that requires a proxy.
--
-- @@
-- do
-- txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText
-- pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay' ::
forall label err m a.
Monad m =>
Proxy label ->
Text ->
Json.ParseT err m a ->
Json.ParseT err m (Label label (Maybe a))
keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser
-- | Like 'Json.key', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamed :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a
keyRenamed (newKey :| oldKeys) inner =
keyRenamedTryOldKeys oldKeys inner >>= \case
Nothing -> Json.key newKey inner
Just parse -> parse
-- | Like 'Json.keyMay', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamedMay :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a)
keyRenamedMay (newKey :| oldKeys) inner =
keyRenamedTryOldKeys oldKeys inner >>= \case
Nothing -> Json.keyMay newKey inner
Just parse -> Just <$> parse
-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any.
keyRenamedTryOldKeys :: Monad m => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a))
keyRenamedTryOldKeys oldKeys inner = do
oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case
Nothing -> Nothing
Just (old :| _moreOld) -> Just old
where
tryOld key =
Json.keyMay key (pure ()) <&> \case
Just () -> Just $ Json.key key inner
Nothing -> Nothing
test_keyRenamed :: Hspec.Spec
test_keyRenamed = do
describe "keyRenamed" $ do
let parser = keyRenamed ("new" :| ["old"]) Json.asText
let p = Json.parseValue @() parser
it "accepts the new key and the old key" $ do
p (Object (KeyMap.singleton "new" (String "text")))
`shouldBe` (Right "text")
p (Object (KeyMap.singleton "old" (String "text")))
`shouldBe` (Right "text")
it "fails with the old key in the error if the inner parser is wrong" $ do
p (Object (KeyMap.singleton "old" Null))
`shouldBe` (Left (Json.BadSchema [Json.ObjectKey "old"] (Json.WrongType Json.TyString Null)))
it "fails with the new key in the error if the inner parser is wrong" $ do
p (Object (KeyMap.singleton "new" Null))
`shouldBe` (Left (Json.BadSchema [Json.ObjectKey "new"] (Json.WrongType Json.TyString Null)))
it "fails if the key is missing" $ do
p (Object KeyMap.empty)
`shouldBe` (Left (Json.BadSchema [] (Json.KeyMissing "new")))
describe "keyRenamedMay" $ do
let parser = keyRenamedMay ("new" :| ["old"]) Json.asText
let p = Json.parseValue @() parser
it "accepts the new key and the old key" $ do
p (Object (KeyMap.singleton "new" (String "text")))
`shouldBe` (Right (Just "text"))
p (Object (KeyMap.singleton "old" (String "text")))
`shouldBe` (Right (Just "text"))
it "allows the old and new key to be missing" $ do
p (Object KeyMap.empty)
`shouldBe` (Right Nothing)
-- | Create a json array from a list of json values.
jsonArray :: [Value] -> Value
jsonArray xs = xs & Vector.fromList & Array
|
