From 11d0fb47c292a0ca25a9c377499d2b221d97a5cb Mon Sep 17 00:00:00 2001
From: Volpeon <github@volpeon.ink>
Date: Fri, 26 May 2023 07:40:13 +0200
Subject: Init

---
 src/Data/JLD/Util.hs | 118 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 118 insertions(+)
 create mode 100644 src/Data/JLD/Util.hs

(limited to 'src/Data/JLD/Util.hs')

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 @@
+module Data.JLD.Util (
+    valueContains,
+    valueContainsAny,
+    valueIsTrue,
+    valueIsString,
+    valueIsArray,
+    valueIsNotArray,
+    valueIsEmptyArray,
+    valueIsScalar,
+    valueToString,
+    valueIsNotString,
+    valueIsNotNull,
+    flattenSingletonArray,
+    valueToArray,
+    allStrings,
+    ifindM,
+    getMapDefault,
+    mapAddValue,
+) where
+
+import Data.JLD.Prelude
+
+import Data.Aeson (Array, Key, Object, Value (..))
+import Data.Aeson.Key qualified as K (fromText)
+import Data.Aeson.KeyMap qualified as KM (insert, lookup, member)
+import Data.Foldable qualified as F (Foldable (..), elem)
+import Data.Foldable.WithIndex (FoldableWithIndex (..), ifoldlM)
+import Data.Vector (Vector)
+import Data.Vector qualified as V (fromList, null, singleton, snoc, uncons)
+
+valueContains :: Text -> Value -> Bool
+valueContains text = \case
+    String s -> s == text
+    Array a -> elem (String text) a
+    Object o -> KM.member (K.fromText text) o
+    _ -> False
+
+valueContainsAny :: (Foldable f, Functor f) => f Text -> Value -> Bool
+valueContainsAny texts = \case
+    String s -> s `F.elem` texts
+    Array a -> any (`elem` a) <| String <$> texts
+    Object o -> any (\text -> KM.member (K.fromText text) o) texts
+    _ -> False
+
+valueIsTrue :: Value -> Bool
+valueIsTrue (Bool True) = True
+valueIsTrue _ = False
+
+valueIsString :: Value -> Bool
+valueIsString (String _) = True
+valueIsString _ = False
+
+valueIsNotString :: Value -> Bool
+valueIsNotString = valueIsString .> not
+
+valueIsArray :: Value -> Bool
+valueIsArray (Array _) = True
+valueIsArray _ = False
+
+valueIsNotArray :: Value -> Bool
+valueIsNotArray = valueIsArray .> not
+
+valueIsEmptyArray :: Value -> Bool
+valueIsEmptyArray (Array a) = V.null a
+valueIsEmptyArray _ = False
+
+valueIsScalar :: Value -> Bool
+valueIsScalar = \case
+    String _ -> True
+    Number _ -> True
+    Bool _ -> True
+    _ -> False
+
+valueToString :: Value -> Maybe Text
+valueToString (String s) = Just s
+valueToString _ = Nothing
+
+valueIsNotNull :: Value -> Bool
+valueIsNotNull Null = False
+valueIsNotNull _ = True
+
+flattenSingletonArray :: Value -> Value
+flattenSingletonArray = \case
+    Array (V.uncons -> Just (value, V.null -> True)) -> value
+    value -> value
+
+valueToArray :: Value -> Array
+valueToArray = \case
+    Array a -> a
+    value -> V.singleton value
+
+allStrings :: Array -> Maybe (Vector Text)
+allStrings = foldl' go (Just mempty)
+  where
+    go :: Maybe (Vector Text) -> Value -> Maybe (Vector Text)
+    go (Just a) (String s) = Just <| V.snoc a s
+    go _ _ = Nothing
+
+ifindM :: (FoldableWithIndex i f, Monad m) => (i -> a -> m Bool) -> f a -> m (Maybe a)
+ifindM p = ifoldlM (\i r x -> p i x <&> bool r (Just x)) Nothing
+
+getMapDefault :: Key -> Object -> Object
+getMapDefault key obj = case KM.lookup key obj of
+    Just (Object o) -> o
+    _ -> mempty
+
+mapAddValue :: Key -> Value -> Bool -> Object -> Object
+mapAddValue key value True object = mapAddValue key value False <| KM.insert key (Array array) object
+  where
+    array = case KM.lookup key object of
+        Just (Array a) -> a
+        Just original -> V.singleton original
+        Nothing -> mempty
+mapAddValue key (Array value) False object = foldl' (\o v -> mapAddValue key v False o) object value
+mapAddValue key value False object = case KM.lookup key object of
+    Just (Array a) -> KM.insert key (Array <| V.snoc a value) object
+    Just original -> KM.insert key (Array <| V.fromList [original, value]) object
+    Nothing -> KM.insert key value object
-- 
cgit v1.2.3-54-g00ecf