add query parser & printer

1 files 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