From 33faca6f99dc207e81497297c205a1ff29ae2f33 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Mon, 12 Feb 2024 05:39:19 +0100
Subject: dissolve `unique`
---
app/Main.hs | 15 +--------------
app/Record.hs | 18 ++++++++++--------
2 files changed, 11 insertions(+), 22 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
index 4eedc97..e7d62bf 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -374,20 +374,7 @@ satisfies :: Maybe WhereClause -> R.Records J.Value -> Bool
satisfies Nothing _ = True
satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws
satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws
-satisfies (Just (Where p)) vs = satisfy p vs
-
-satisfy :: Comparison -> R.Records J.Value -> Bool
-satisfy (Eq f g) vs = unique f vs == unique g vs
-
-data DuplicateField' = DuplicateField'
- deriving (Show)
-
-instance Exception DuplicateField'
-
-unique :: F.Field -> R.Records J.Value -> J.Value
-unique f as = case mapMaybe (R.lookup f) as of
- [v] -> v
- (_ : _) -> throw DuplicateField'
+satisfies (Just (Where (Eq f g))) vs = R.lookups f vs == R.lookups g vs
query' :: Query -> IO ()
query' q = mapM_ (LB.putStrLn . J.encode) =<< query q
diff --git a/app/Record.hs b/app/Record.hs
index d23d289..30e98ec 100644
--- a/app/Record.hs
+++ b/app/Record.hs
@@ -4,6 +4,7 @@ module Record
toValue,
lookup,
Records,
+ lookups,
select,
disjointUnion,
disjointUnions,
@@ -16,7 +17,7 @@ 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 (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text qualified as T
import Exception (DuplicateField (DuplicateField))
import Field qualified as F
@@ -48,18 +49,19 @@ lookup' (k : ks) (J.Object 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 (select' rs f)) fs)
-
-select' :: Records J.Value -> F.Field -> J.Value
-select' rs f = case mapMaybe (lookup f) rs of
- [] -> J.Null
- [v] -> v
- (_ : _) -> throw (DuplicateField (F.toString f))
+ (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)
--
cgit v1.2.3