aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Store/Query.hs28
-rw-r--r--src/Store/Query/Field.hs10
-rw-r--r--src/Store/Query/Parser.hs67
-rw-r--r--src/Store/Query/Printer.hs5
-rw-r--r--src/Store/Query/Record.hs20
-rw-r--r--src/Store/Query/Type.hs6
6 files changed, 72 insertions, 64 deletions
diff --git a/src/Store/Query.hs b/src/Store/Query.hs
index b63b176..f8575af 100644
--- a/src/Store/Query.hs
+++ b/src/Store/Query.hs
@@ -9,7 +9,7 @@ import Data.Aeson qualified as J
import Data.Aeson.Key qualified as JK
import Data.Aeson.KeyMap qualified as JM
import Data.List (foldl', isSuffixOf)
-import Data.List.NonEmpty qualified as N
+import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Vector qualified as V
import Store.Exception (DecodeException (DecodeException))
@@ -61,17 +61,12 @@ embed vss (EmbedClause (Record c es) w) =
vs
++ [ fromValue
c
- ( J.Object
- ( JM.singleton
- (JK.fromString c)
- ( J.Array
- ( V.fromList
- [ e
- | e <- es,
- satisfies w (vs ++ [Record c e])
- ]
- )
- )
+ ( J.Array
+ ( V.fromList
+ [ e
+ | e <- es,
+ satisfies w (vs ++ [Record c e])
+ ]
)
)
]
@@ -117,8 +112,13 @@ join vss (JoinClause JoinFull js w) =
js
select :: FieldSelector -> Records J.Value -> J.Value
-select All vs = disjointUnions (map toValue vs)
-select (Only fs) vs = Store.Query.Record.select (N.toList fs) vs
+select (SelectObject kvs) vs =
+ J.Object
+ . JM.fromMap
+ . M.mapKeys JK.fromString
+ . (M.map (\s -> Store.Query.select s vs))
+ $ kvs
+select (SelectField f) vs = fromMaybe J.Null (lookups f vs)
where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
where_ w = filter (satisfies w)
diff --git a/src/Store/Query/Field.hs b/src/Store/Query/Field.hs
index 69a0983..3078a34 100644
--- a/src/Store/Query/Field.hs
+++ b/src/Store/Query/Field.hs
@@ -9,23 +9,19 @@ import Data.Aeson qualified as J
import Data.Aeson.Key qualified as JK
import Data.Aeson.KeyMap qualified as JM
import Data.List (intercalate)
-import Data.List.NonEmpty qualified as N
import Data.Text qualified as T
data Field
- = Qualified Collection (N.NonEmpty T.Text)
- | Unqualified (N.NonEmpty T.Text)
+ = Field Collection [T.Text]
deriving (Show)
toString :: Field -> String
-toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks))
-toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks))
+toString (Field c ks) = intercalate "." (c : map T.unpack ks)
type Collection = FilePath
prefix :: Field -> J.Value -> J.Value
-prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks)
-prefix (Unqualified ks) = prefix' (N.toList ks)
+prefix (Field c ks) = prefix' (T.pack c : ks)
prefix' :: [T.Text] -> J.Value -> J.Value
prefix' ks v =
diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs
index 93e408c..cb02f32 100644
--- a/src/Store/Query/Parser.hs
+++ b/src/Store/Query/Parser.hs
@@ -4,9 +4,8 @@ module Store.Query.Parser () where
import Control.Exception (throw)
import Control.Monad (void)
-import Control.Monad.Combinators.NonEmpty qualified as PN
import Data.Char (isSpace)
-import Data.List.NonEmpty qualified as N
+import Data.Map qualified as M
import Data.String (IsString (fromString))
import Data.Text qualified as T
import Data.Void (Void)
@@ -39,6 +38,7 @@ instance IsString Query where
lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
and = void $ lexeme (P.string "AND")
+ colon = void $ lexeme (P.string ":")
comma = void $ lexeme (P.string ",")
embed = void $ lexeme (P.string "EMBED")
eq = void $ lexeme (P.string "==")
@@ -84,26 +84,55 @@ instance IsString Query where
pure $ Eq a b
fieldSelector =
- P.choice
- [ do
- void $ lexeme $ P.string "*"
- pure All,
- do
- Only <$> PN.sepBy1 field comma
- ]
+ lexeme $
+ P.choice
+ [ do
+ void $ lexeme $ P.string "{"
+ kvs <-
+ P.sepBy
+ ( P.choice
+ [ P.try do
+ k <-
+ lexeme $
+ P.takeWhile1P
+ Nothing
+ ( \c ->
+ not (isSpace c)
+ && c /= '.'
+ && c /= ','
+ && c /= ':'
+ )
+ lexeme $ colon
+ v <- fieldSelector
+ pure (k, v),
+ do
+ f@(Field c ks) <- field
+ let k
+ | null ks = c
+ | otherwise = T.unpack (last ks)
+ pure (k, SelectField f)
+ ]
+ )
+ comma
+ void $ lexeme $ P.string "}"
+ pure $ SelectObject (M.fromList kvs),
+ do
+ SelectField <$> field
+ ]
field :: P.Parsec Void String Field
field =
- lexeme . P.choice $
- [ P.try
- do
- Qualified
- <$> (fieldPart <* P.string ".")
- <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")),
- do
- Unqualified
- <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string "."))
- ]
+ lexeme do
+ Field
+ <$> fieldPart
+ <*> ( P.choice
+ [ do
+ void $ P.string "."
+ map T.pack <$> P.sepBy fieldPart (P.string "."),
+ do
+ pure []
+ ]
+ )
fieldPart :: P.Parsec Void String String
fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')
diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs
index 5692ba8..7861bc9 100644
--- a/src/Store/Query/Printer.hs
+++ b/src/Store/Query/Printer.hs
@@ -3,7 +3,6 @@
module Store.Query.Printer () where
import Data.List (intercalate)
-import Data.List.NonEmpty qualified as N
import Data.Maybe (catMaybes, mapMaybe)
import Store.Query.Field
import Store.Query.Type
@@ -21,9 +20,7 @@ instance Show Query where
showWhereClause w
]
where
- showFieldSelector All = "*"
- showFieldSelector (Only (N.toList -> fs)) =
- intercalate ", " (map showField fs)
+ showFieldSelector = error "showFieldSelector"
showField = Store.Query.Field.toString
showCollection c = c
showJoinClauses js = case map showJoinClause js of
diff --git a/src/Store/Query/Record.hs b/src/Store/Query/Record.hs
index 71461d5..b00be27 100644
--- a/src/Store/Query/Record.hs
+++ b/src/Store/Query/Record.hs
@@ -5,7 +5,6 @@ module Store.Query.Record
lookup,
Records,
lookups,
- select,
disjointUnion,
disjointUnions,
)
@@ -16,8 +15,7 @@ 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.Maybe (mapMaybe)
import Data.Text qualified as T
import Store.Exception (DuplicateField (DuplicateField))
import Store.Query.Field
@@ -36,10 +34,8 @@ toValue :: Record a -> a
toValue (Record _ v) = v
lookup :: Field -> Record J.Value -> Maybe J.Value
-lookup (Unqualified ks) (Record _ v) =
- lookup' (N.toList ks) v
-lookup (Qualified c' ks) (Record c v)
- | c' == c = lookup' (N.toList ks) v
+lookup (Field c' ks) (Record c v)
+ | c' == c = lookup' ks v
| otherwise = Nothing
lookup' :: [T.Text] -> J.Value -> Maybe J.Value
@@ -56,16 +52,6 @@ lookups f rs =
[v] -> Just v
(_ : _) -> throw (DuplicateField (toString f))
-select :: [Field] -> Records J.Value -> J.Value
-select fs rs =
- foldl'
- union
- (J.Object JM.empty)
- (map (\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)
diff --git a/src/Store/Query/Type.hs b/src/Store/Query/Type.hs
index 5aa0e36..abf2c77 100644
--- a/src/Store/Query/Type.hs
+++ b/src/Store/Query/Type.hs
@@ -14,7 +14,7 @@ module Store.Query.Type
)
where
-import Data.List.NonEmpty qualified as N
+import Data.Map qualified as M
import Store.Query.Field
import Store.Query.Record
@@ -27,8 +27,8 @@ data Query
(Maybe WhereClause)
data FieldSelector
- = All
- | Only (N.NonEmpty Field)
+ = SelectObject (M.Map String FieldSelector)
+ | SelectField Field
deriving (Show)
type Collection = FilePath
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 09:41:45 +0000