From bbe3b75bfd0767c61bcd436e843b9c785efd289f Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Mon, 19 Feb 2024 04:55:36 +0100 Subject: support `INSERT`, `DELETE`, `UPDATE` --- src/Store/Query/Parser.hs | 115 +++++++++++++++++++++++++++++---- src/Store/Query/Printer.hs | 157 ++++++++++++++++++++++++++++++++------------- src/Store/Query/Record.hs | 6 ++ src/Store/Query/Type.hs | 6 +- 4 files changed, 226 insertions(+), 58 deletions(-) (limited to 'src/Store/Query') diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs index cb02f32..e16c926 100644 --- a/src/Store/Query/Parser.hs +++ b/src/Store/Query/Parser.hs @@ -4,10 +4,14 @@ module Store.Query.Parser () where import Control.Exception (throw) import Control.Monad (void) +import Data.Aeson qualified as J +import Data.Aeson.Key qualified as JK +import Data.Aeson.KeyMap qualified as JM import Data.Char (isSpace) import Data.Map qualified as M import Data.String (IsString (fromString)) import Data.Text qualified as T +import Data.Vector qualified as V import Data.Void (Void) import Store.Exception (ParseError (ParseError)) import Store.Query.Type @@ -22,21 +26,53 @@ instance IsString Query where where parser = do void $ P.many P.space1 - select - fs <- fieldSelector - from - c <- collection - js <- joinClauses - es <- embedClauses - w <- P.optional do - where_ - whereClause - P.eof - pure $ Select fs c js es w + P.choice + [ do + delete + from + c <- collection + w <- P.optional do + where_ + whereClause + pure $ Delete c w, + do + insert + vs <- objects + into + c <- collection + pure $ Insert vs c, + do + select + fs <- fieldSelector + from + c <- collection + js <- joinClauses + es <- embedClauses + w <- P.optional do + where_ + whereClause + pure $ Select fs c js es w, + do + update + c <- collection + set + v <- object + w <- + P.optional do + where_ + whereClause + pure $ Update c v w + ] + <* P.eof lexeme :: P.Parsec Void String a -> P.Parsec Void String a lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace + set = void $ lexeme (P.string "SET") + update = void $ lexeme (P.string "UPDATE") + into = void $ lexeme (P.string "INTO") + insert = void $ lexeme (P.string "INSERT") + delete = void $ lexeme (P.string "DELETE") and = void $ lexeme (P.string "AND") colon = void $ lexeme (P.string ":") comma = void $ lexeme (P.string ",") @@ -120,6 +156,63 @@ instance IsString Query where SelectField <$> field ] + objects = P.sepBy object comma + + object = lexeme do + void $ lexeme $ P.string "{" + kvs <- + P.sepBy + ( do + k <- + lexeme $ do + void $ lexeme $ P.string "\"" + P.takeWhile1P + Nothing + (/= '\"') + <* (void $ lexeme $ P.string "\"") + lexeme $ colon + v <- value + pure (JK.fromString k, v) + ) + comma + void $ lexeme $ P.string "}" + pure $ J.Object (JM.fromList kvs) + + value = + P.choice + [ object, + array, + string, + number, + bool, + null_ + ] + + array = lexeme do + void $ lexeme $ P.string "[" + vs <- P.sepBy value comma + void $ lexeme $ P.string "]" + pure $ J.Array (V.fromList vs) + + string = lexeme do + void $ lexeme $ P.string "\"" + s <- P.takeWhileP Nothing (\c -> c /= '\"') + void $ lexeme $ P.string "\"" + pure $ J.String (T.pack s) + + number = lexeme do + J.Number <$> P.scientific + + bool = lexeme do + J.Bool + <$> P.choice + [ const True <$> P.string "true", + const False <$> P.string "false" + ] + + null_ = lexeme do + const J.Null <$> P.string "null" + field :: P.Parsec Void String Field field = lexeme do diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs index 7861bc9..26f4e8b 100644 --- a/src/Store/Query/Printer.hs +++ b/src/Store/Query/Printer.hs @@ -2,56 +2,121 @@ module Store.Query.Printer () where +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.Maybe (catMaybes, mapMaybe) +import Data.Text qualified as T +import Data.Vector qualified as V import Store.Query.Field import Store.Query.Type instance Show Query where + show (Delete c w) = + intercalate " " . catMaybes $ + [ Just "DELETE FROM ", + Just (showCollection c), + showWhereClause w + ] + show (Insert vs c) = + intercalate " " . catMaybes $ + [ Just "INSERT", + showValues vs, + Just "INTO", + Just (showCollection c) + ] show (Select fs c js es w) = - intercalate " " $ - catMaybes $ - [ Just "SELECT", - Just (showFieldSelector fs), - Just "FROM", - Just (showCollection c), - showJoinClauses js, - showEmbedClauses es, - showWhereClause w - ] - where - showFieldSelector = error "showFieldSelector" - showField = Store.Query.Field.toString - showCollection c = c - showJoinClauses js = case map showJoinClause js of - [] -> Nothing - xs -> Just (intercalate " " xs) - showJoinClause (JoinClause t c w) = - intercalate " " $ - catMaybes $ - [ Just (showJoinType t), - Just (showCollection c), - Just "ON", - showWhereClause w - ] - showJoinType JoinLeft = "LEFT JOIN" - showJoinType JoinRight = "RIGHT JOIN" - showJoinType JoinFull = "FULL JOIN" - showEmbedClauses js = case map showEmbedClause js of - [] -> Nothing - xs -> Just (intercalate " " xs) - showEmbedClause (EmbedClause c w) = - intercalate " " $ - catMaybes $ - [ Just "EMBED", - Just (showCollection c), - Just "ON", - showWhereClause w - ] - showWhereClause = showWhereClauseWith id - showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")") - showWhereClauseWith _ Nothing = Nothing - showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws))) - showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws))) - showWhereClauseWith _ (Just (Where p)) = Just (showComparison p) - showComparison (Eq a b) = intercalate " " [showField a, "==", showField b] + intercalate " " . catMaybes $ + [ Just "SELECT", + Just (showFieldSelector fs), + Just "FROM", + Just (showCollection c), + showJoinClauses js, + showEmbedClauses es, + showWhereClause w + ] + show (Update c v w) = + intercalate " " . catMaybes $ + [ Just "UPDATE", + Just (showCollection c), + Just "SET", + Just (showValue v), + showWhereClause w + ] + +showFieldSelector :: FieldSelector -> String +showFieldSelector = error "showFieldSelector" + +showField :: Field -> String +showField = Store.Query.Field.toString + +showCollection :: Collection -> String +showCollection c = c + +showJoinClauses :: [JoinClause String] -> Maybe String +showJoinClauses js = case map showJoinClause js of + [] -> Nothing + xs -> Just (intercalate " " xs) + +showJoinClause :: JoinClause String -> String +showJoinClause (JoinClause t c w) = + intercalate " " $ + catMaybes $ + [ Just (showJoinType t), + Just (showCollection c), + Just "ON", + showWhereClause w + ] + +showJoinType :: JoinType -> String +showJoinType JoinLeft = "LEFT JOIN" +showJoinType JoinRight = "RIGHT JOIN" +showJoinType JoinFull = "FULL JOIN" + +showEmbedClauses :: [EmbedClause String] -> Maybe String +showEmbedClauses js = case map showEmbedClause js of + [] -> Nothing + xs -> Just (intercalate " " xs) + +showEmbedClause :: EmbedClause String -> String +showEmbedClause (EmbedClause c w) = + intercalate " " $ + catMaybes $ + [ Just "EMBED", + Just (showCollection c), + Just "ON", + showWhereClause w + ] + +showWhereClause :: Maybe WhereClause -> Maybe String +showWhereClause = showWhereClauseWith id + +showWhereClause' :: Maybe WhereClause -> Maybe String +showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")") + +showWhereClauseWith :: (String -> String) -> Maybe WhereClause -> Maybe String +showWhereClauseWith _ Nothing = Nothing +showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws))) +showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws))) +showWhereClauseWith _ (Just (Where p)) = Just (showComparison p) + +showComparison :: Comparison -> String +showComparison (Eq a b) = intercalate " " [showField a, "==", showField b] + +showValues :: [J.Value] -> Maybe String +showValues [] = Nothing +showValues vs = Just (intercalate ", " (map showValue vs)) + +showValue :: J.Value -> String +showValue (J.Object kvs) = + intercalate + ",\n" + (map (\(k, v) -> "\"" <> JK.toString k <> "\" : " <> showValue v) (JM.toList kvs)) +showValue (J.Array (V.toList -> vs)) = + "[" <> intercalate ", " (map showValue vs) <> "]" +showValue (J.String c) = "\"" <> T.unpack c <> "\"" +showValue (J.Number c) = show c +showValue (J.Bool True) = "true" +showValue (J.Bool False) = "false" +showValue J.Null = "null" diff --git a/src/Store/Query/Record.hs b/src/Store/Query/Record.hs index b00be27..d663716 100644 --- a/src/Store/Query/Record.hs +++ b/src/Store/Query/Record.hs @@ -5,6 +5,7 @@ module Store.Query.Record lookup, Records, lookups, + union, disjointUnion, disjointUnions, ) @@ -52,6 +53,11 @@ lookups f rs = [v] -> Just v (_ : _) -> throw (DuplicateField (toString f)) +union :: J.Value -> J.Value -> J.Value +union (J.Object r) (J.Object s) = + J.Object (JM.unionWith union r s) +union _ s = 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 abf2c77..7065267 100644 --- a/src/Store/Query/Type.hs +++ b/src/Store/Query/Type.hs @@ -14,17 +14,21 @@ module Store.Query.Type ) where +import Data.Aeson qualified as J import Data.Map qualified as M import Store.Query.Field import Store.Query.Record data Query - = Select + = Delete Collection (Maybe WhereClause) + | Insert [J.Value] Collection + | Select FieldSelector Collection (JoinClauses FilePath) (EmbedClauses FilePath) (Maybe WhereClause) + | Update Collection J.Value (Maybe WhereClause) data FieldSelector = SelectObject (M.Map String FieldSelector) -- cgit v1.2.3