From d819f3ae93d7fff0c91a559ab9a49157513ba6a8 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Fri, 9 Feb 2024 15:22:05 +0100 Subject: add query parser & printer --- app/Main.hs | 206 ++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 144 insertions(+), 62 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 5ce4dd0..a5efb6d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,86 +5,80 @@ module Main where import Control.Exception (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.ByteString.Lazy.Char8 qualified as LB -import Data.List (foldl', isSuffixOf) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Char (isSpace) +import Data.List (foldl', intercalate, isSuffixOf) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Set qualified as S import Data.String (IsString (fromString)) import Data.Text qualified as T +import Data.Void (Void) import Store qualified as S import System.Directory (setCurrentDirectory) import System.FilePath (()) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Text.Megaparsec.Char.Lexer qualified as P +import Text.Printf (printf) main :: IO () main = do setCurrentDirectory "./data" - putStrLn "> SELECT * FROM c" - query' $ Select All "c" [] [] - - putStrLn "\n> SELECT * FROM j" - query' $ Select All "j" [] [] - - putStrLn "\n> SELECT c.id, j.id, is_j FROM c LEFT JOIN j ON j.id == c.j_id" - query' $ - Select - ( Only - [ Qualified "c" "id", - Qualified "j" "id", - Unqualified "is_j" - ] - ) - "c" - [ JoinClause - JoinLeft - "j" - [ Eq (Qualified "j" "id") (Qualified "c" "j_id") - ] - ] - [] - - putStrLn "\n> SELECT c.id, j.id FROM c RIGHT JOIN j ON j.id == c.j_id" - query' $ - Select - ( Only - [ Qualified "c" "id", - Qualified "j" "id" - ] - ) - "c" - [ JoinClause - JoinRight - "j" - [ Eq (Qualified "j" "id") (Qualified "c" "j_id") - ] - ] - [] - - putStrLn "\n> SELECT c.id, j.id FROM c FULL JOIN j ON j.id == c.j_id" - query' $ - Select - ( Only - [ Qualified "c" "id", - Qualified "j" "id" - ] - ) - "c" - [ JoinClause - JoinFull - "j" - [ Eq (Qualified "j" "id") (Qualified "c" "j_id") - ] - ] - [] + + mapM_ + ( \q -> do + printf "> %s\n" (show q) + query' q + ) + [ "SELECT * FROM c", + "SELECT * FROM j", + "SELECT c.id, j.id, is_j FROM c LEFT JOIN j ON j.id == c.j_id", + "SELECT c.id, j.id FROM c RIGHT JOIN j ON j.id == c.j_id", + "SELECT c.id, j.id FROM c FULL JOIN j ON j.id == c.j_id" + ] data Query = Select FieldSelector Collection (JoinClauses FilePath) WhereClauses - deriving (Show) + +instance Show Query where + show (Select fs c js ws) = + intercalate " " $ + catMaybes $ + [ Just "SELECT", + Just (showFieldSelector fs), + Just "FROM", + Just (showCollection c), + showJoinClauses js, + showWhereClauses ws + ] + where + showFieldSelector All = "*" + showFieldSelector (Only fs) = intercalate ", " (map showField fs) + showField (Qualified c k) = c <> "." <> T.unpack k + showField (Unqualified k) = T.unpack k + showCollection c = c + showJoinClauses js = case map showJoinClause js of + [] -> Nothing + xs -> Just (intercalate " " xs) + showJoinClause (JoinClause t c ws) = + intercalate " " $ + catMaybes $ + [ Just (showJoinType t), + Just (showCollection c), + Just "ON", + showWhereClauses ws + ] + showJoinType JoinLeft = "LEFT JOIN" + showJoinType JoinRight = "RIGHT JOIN" + showJoinType JoinFull = "FULL JOIN" + showWhereClauses ws = case map showWhereClause ws of + [] -> Nothing + xs -> Just (intercalate " " xs) + showWhereClause (Eq a b) = intercalate " " [showField a, "==", showField b] data FieldSelector = All @@ -120,10 +114,98 @@ data Record a = Record FilePath a deriving (Show, Eq) -{- +data ParseError = ParseError String + deriving (Show) + +instance Exception ParseError + instance IsString Query where fromString = - either throw id (P.parse parser "" s)-} + either (throw . ParseError . P.errorBundlePretty @String @Void) id + . P.parse parser "" + where + parser = do + void $ P.many P.space1 + select + fs <- fieldSelector + from + c <- collection + js <- joinClauses + ws <- + fromMaybe [] <$> P.optional do + where_ + whereClauses1 + P.eof + pure $ Select fs c js ws + + lexeme :: P.Parsec Void String a -> P.Parsec Void String a + lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace + + comma, eq, from, on, select, where_ :: P.Parsec Void String () + comma = void $ lexeme (P.string ",") + eq = void $ lexeme (P.string "==") + from = void $ lexeme (P.string "FROM") + on = void $ lexeme (P.string "ON") + select = void $ lexeme (P.string "SELECT") + where_ = void $ lexeme (P.string "WHERE") + + collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace) + + joinClauses = P.many joinClause + + joinClause = do + t <- joinType + c <- collection + on + ws <- whereClauses + pure $ JoinClause t c ws + + whereClauses1 = P.some whereClause + whereClauses = P.many whereClause + + whereClause = do + a <- field + eq + b <- field + pure $ Eq a b + + fieldSelector = + P.choice + [ do + void $ lexeme $ P.string "*" + pure All, + do + Only <$> P.sepBy1 field comma + ] + + field :: P.Parsec Void String Field + field = + lexeme . P.choice $ + [ P.try do + Qualified + <$> (P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')) + <*> (P.string "." >> T.pack <$> P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',')), + do + Unqualified + <$> (T.pack <$> P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',')) + ] + + joinType :: P.Parsec Void String JoinType + joinType = + P.choice + [ do + void $ lexeme (P.string "LEFT") + void $ lexeme (P.string "JOIN") + pure JoinLeft, + do + void $ lexeme (P.string "RIGHT") + void $ lexeme (P.string "JOIN") + pure JoinRight, + do + void $ lexeme (P.string "FULL") + void $ lexeme (P.string "JOIN") + pure JoinFull + ] query :: Query -> IO [J.Value] query (Select fs c js ws) = do -- cgit v1.2.3