blob: 30e98eceeae47aaa31da185591aeb6fded0d2408 (
plain)
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
|
module Record
( Record (..),
fromValue,
toValue,
lookup,
Records,
lookups,
select,
disjointUnion,
disjointUnions,
)
where
import Control.Exception (throw)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as JK
import Data.Aeson.KeyMap qualified as JM
import Data.List (foldl')
import Data.List.NonEmpty qualified as N
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text qualified as T
import Exception (DuplicateField (DuplicateField))
import Field qualified as F
import Prelude hiding (lookup)
data Record a
= Record Collection a
deriving (Show, Eq)
type Collection = FilePath
fromValue :: Collection -> a -> Record a
fromValue = Record
toValue :: Record a -> a
toValue (Record _ v) = v
lookup :: F.Field -> Record J.Value -> Maybe J.Value
lookup (F.Unqualified ks) (Record _ v) =
lookup' (N.toList ks) v
lookup (F.Qualified c' ks) (Record c v)
| c' == c = lookup' (N.toList ks) v
| otherwise = Nothing
lookup' :: [T.Text] -> J.Value -> Maybe J.Value
lookup' [] v = Just v
lookup' (k : ks) (J.Object kvs) =
lookup' ks =<< JM.lookup (JK.fromText k) kvs
type Records a = [Record a]
lookups :: F.Field -> Records J.Value -> Maybe J.Value
lookups f rs =
case mapMaybe (lookup f) rs of
[] -> Nothing
[v] -> Just v
(_ : _) -> throw (DuplicateField (F.toString f))
select :: [F.Field] -> Records J.Value -> J.Value
select fs rs =
foldl'
union
(J.Object JM.empty)
(map (\f -> F.prefix f ((fromMaybe J.Null (lookups f rs)))) fs)
union :: J.Value -> J.Value -> J.Value
union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s)
disjointUnion :: J.Value -> J.Value -> J.Value
disjointUnion (J.Object r) (J.Object s) =
J.Object (JM.unionWithKey disjointUnion' r s)
disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
disjointUnion' _ (J.Object r) (J.Object s) =
J.Object (JM.unionWithKey disjointUnion' r s)
disjointUnion' k _ _ =
throw (DuplicateField (JK.toString k))
disjointUnions :: [J.Value] -> J.Value
disjointUnions = foldl' disjointUnion (J.Object JM.empty)
|
