diff options
Diffstat (limited to 'src/Data/JLD/Util.hs')
-rw-r--r-- | src/Data/JLD/Util.hs | 118 |
1 files changed, 118 insertions, 0 deletions
diff --git a/src/Data/JLD/Util.hs b/src/Data/JLD/Util.hs new file mode 100644 index 0000000..82cbdee --- /dev/null +++ b/src/Data/JLD/Util.hs | |||
@@ -0,0 +1,118 @@ | |||
1 | module Data.JLD.Util ( | ||
2 | valueContains, | ||
3 | valueContainsAny, | ||
4 | valueIsTrue, | ||
5 | valueIsString, | ||
6 | valueIsArray, | ||
7 | valueIsNotArray, | ||
8 | valueIsEmptyArray, | ||
9 | valueIsScalar, | ||
10 | valueToString, | ||
11 | valueIsNotString, | ||
12 | valueIsNotNull, | ||
13 | flattenSingletonArray, | ||
14 | valueToArray, | ||
15 | allStrings, | ||
16 | ifindM, | ||
17 | getMapDefault, | ||
18 | mapAddValue, | ||
19 | ) where | ||
20 | |||
21 | import Data.JLD.Prelude | ||
22 | |||
23 | import Data.Aeson (Array, Key, Object, Value (..)) | ||
24 | import Data.Aeson.Key qualified as K (fromText) | ||
25 | import Data.Aeson.KeyMap qualified as KM (insert, lookup, member) | ||
26 | import Data.Foldable qualified as F (Foldable (..), elem) | ||
27 | import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM) | ||
28 | import Data.Vector (Vector) | ||
29 | import Data.Vector qualified as V (fromList, null, singleton, snoc, uncons) | ||
30 | |||
31 | valueContains :: Text -> Value -> Bool | ||
32 | valueContains text = \case | ||
33 | String s -> s == text | ||
34 | Array a -> elem (String text) a | ||
35 | Object o -> KM.member (K.fromText text) o | ||
36 | _ -> False | ||
37 | |||
38 | valueContainsAny :: (Foldable f, Functor f) => f Text -> Value -> Bool | ||
39 | valueContainsAny texts = \case | ||
40 | String s -> s `F.elem` texts | ||
41 | Array a -> any (`elem` a) <| String <$> texts | ||
42 | Object o -> any (\text -> KM.member (K.fromText text) o) texts | ||
43 | _ -> False | ||
44 | |||
45 | valueIsTrue :: Value -> Bool | ||
46 | valueIsTrue (Bool True) = True | ||
47 | valueIsTrue _ = False | ||
48 | |||
49 | valueIsString :: Value -> Bool | ||
50 | valueIsString (String _) = True | ||
51 | valueIsString _ = False | ||
52 | |||
53 | valueIsNotString :: Value -> Bool | ||
54 | valueIsNotString = valueIsString .> not | ||
55 | |||
56 | valueIsArray :: Value -> Bool | ||
57 | valueIsArray (Array _) = True | ||
58 | valueIsArray _ = False | ||
59 | |||
60 | valueIsNotArray :: Value -> Bool | ||
61 | valueIsNotArray = valueIsArray .> not | ||
62 | |||
63 | valueIsEmptyArray :: Value -> Bool | ||
64 | valueIsEmptyArray (Array a) = V.null a | ||
65 | valueIsEmptyArray _ = False | ||
66 | |||
67 | valueIsScalar :: Value -> Bool | ||
68 | valueIsScalar = \case | ||
69 | String _ -> True | ||
70 | Number _ -> True | ||
71 | Bool _ -> True | ||
72 | _ -> False | ||
73 | |||
74 | valueToString :: Value -> Maybe Text | ||
75 | valueToString (String s) = Just s | ||
76 | valueToString _ = Nothing | ||
77 | |||
78 | valueIsNotNull :: Value -> Bool | ||
79 | valueIsNotNull Null = False | ||
80 | valueIsNotNull _ = True | ||
81 | |||
82 | flattenSingletonArray :: Value -> Value | ||
83 | flattenSingletonArray = \case | ||
84 | Array (V.uncons -> Just (value, V.null -> True)) -> value | ||
85 | value -> value | ||
86 | |||
87 | valueToArray :: Value -> Array | ||
88 | valueToArray = \case | ||
89 | Array a -> a | ||
90 | value -> V.singleton value | ||
91 | |||
92 | allStrings :: Array -> Maybe (Vector Text) | ||
93 | allStrings = foldl' go (Just mempty) | ||
94 | where | ||
95 | go :: Maybe (Vector Text) -> Value -> Maybe (Vector Text) | ||
96 | go (Just a) (String s) = Just <| V.snoc a s | ||
97 | go _ _ = Nothing | ||
98 | |||
99 | ifindM :: (FoldableWithIndex i f, Monad m) => (i -> a -> m Bool) -> f a -> m (Maybe a) | ||
100 | ifindM p = ifoldlM (\i r x -> p i x <&> bool r (Just x)) Nothing | ||
101 | |||
102 | getMapDefault :: Key -> Object -> Object | ||
103 | getMapDefault key obj = case KM.lookup key obj of | ||
104 | Just (Object o) -> o | ||
105 | _ -> mempty | ||
106 | |||
107 | mapAddValue :: Key -> Value -> Bool -> Object -> Object | ||
108 | mapAddValue key value True object = mapAddValue key value False <| KM.insert key (Array array) object | ||
109 | where | ||
110 | array = case KM.lookup key object of | ||
111 | Just (Array a) -> a | ||
112 | Just original -> V.singleton original | ||
113 | Nothing -> mempty | ||
114 | mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value | ||
115 | mapAddValue key value False object = case KM.lookup key object of | ||
116 | Just (Array a) -> KM.insert key (Array <| V.snoc a value) object | ||
117 | Just original -> KM.insert key (Array <| V.fromList [original, value]) object | ||
118 | Nothing -> KM.insert key value object | ||