refactor `Query`

1 files changed, 126 insertions, 0 deletions

diff --git a/app/Query/Parser.hs b/app/Query/Parser.hs
new file mode 100644
index 0000000..f2012e2
--- /dev/null
+++ b/app/Query/Parser.hs
@@ -0,0 +1,126 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module 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.String (IsString (fromString))
+import Data.Text qualified as T
+import Data.Void (Void)
+import Exception (ParseError (ParseError))
+import Query.Type
+import Text.Megaparsec qualified as P
+import Text.Megaparsec.Char qualified as P
+import Text.Megaparsec.Char.Lexer qualified as P
+
+instance IsString Query where
+  fromString =
+    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
+        es <- embedClauses
+        w <- P.optional do
+          where_
+          whereClause
+        P.eof
+        pure $ Select fs c js es w
+
+      lexeme :: P.Parsec Void String a -> P.Parsec Void String a
+      lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
+
+      and = void $ lexeme (P.string "AND")
+      comma = void $ lexeme (P.string ",")
+      embed = void $ lexeme (P.string "EMBED")
+      eq = void $ lexeme (P.string "==")
+      from = void $ lexeme (P.string "FROM")
+      on = void $ lexeme (P.string "ON")
+      or = void $ lexeme (P.string "OR")
+      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
+        w <- P.optional do
+          on
+          whereClause
+        pure $ JoinClause t c w
+
+      embedClauses = P.many embedClause
+
+      embedClause = do
+        embed
+        c <- collection
+        w <- P.optional do
+          on
+          whereClause
+        pure $ EmbedClause c w
+
+      whereClause =
+        P.choice
+          [ P.try (And . map Where <$> P.sepBy1 comparison and),
+            P.try (Or . map Where <$> P.sepBy1 comparison or),
+            Where <$> comparison
+          ]
+
+      comparison = do
+        a <- field
+        eq
+        b <- field
+        pure $ Eq a b
+
+      fieldSelector =
+        P.choice
+          [ do
+              void $ lexeme $ P.string "*"
+              pure All,
+            do
+              Only <$> PN.sepBy1 field comma
+          ]
+
+      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 "."))
+          ]
+
+      fieldPart :: P.Parsec Void String String
+      fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && 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
+          ]