aboutsummaryrefslogtreecommitdiffstats
path: root/app/Query
diff options
context:
space:
mode:
Diffstat (limited to 'app/Query')
-rw-r--r--app/Query/Field.hs32
-rw-r--r--app/Query/Parser.hs126
-rw-r--r--app/Query/Printer.hs60
-rw-r--r--app/Query/Record.hs80
-rw-r--r--app/Query/Type.hs62
5 files changed, 360 insertions, 0 deletions
diff --git a/app/Query/Field.hs b/app/Query/Field.hs
new file mode 100644
index 0000000..cdb977a
--- /dev/null
+++ b/app/Query/Field.hs
@@ -0,0 +1,32 @@
+module Query.Field
+ ( Field (..),
+ toString,
+ prefix,
+ )
+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.List.NonEmpty qualified as N
+import Data.Text qualified as T
+
+data Field
+ = Qualified Collection (N.NonEmpty T.Text)
+ | Unqualified (N.NonEmpty 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))
+
+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' :: [T.Text] -> J.Value -> J.Value
+prefix' ks v =
+ foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks)
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
+ ]
diff --git a/app/Query/Printer.hs b/app/Query/Printer.hs
new file mode 100644
index 0000000..e43b7d0
--- /dev/null
+++ b/app/Query/Printer.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Query.Printer () where
+
+import Data.List (intercalate)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (catMaybes, mapMaybe)
+import Query.Field
+import Query.Type
+
+instance Show Query where
+ 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 All = "*"
+ showFieldSelector (Only (N.toList -> fs)) =
+ intercalate ", " (map showField fs)
+ showField = 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]
diff --git a/app/Query/Record.hs b/app/Query/Record.hs
new file mode 100644
index 0000000..b1b3329
--- /dev/null
+++ b/app/Query/Record.hs
@@ -0,0 +1,80 @@
+module Query.Record
+ ( Record (..),
+ fromValue,
+ toValue,
+ lookup,
+ Records,
+ lookups,
+ select,
+ disjointUnion,
+ disjointUnions,
+ )
+where
+
+import Control.Exception (throw)
+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.Text qualified as T
+import Exception (DuplicateField (DuplicateField))
+import Query.Field
+import Prelude hiding (lookup)
+
+data Record a
+ = Record Collection a
+ deriving (Show, Eq)
+
+type Collection = FilePath
+
+fromValue :: Collection -> a -> Record a
+fromValue = Record
+
+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
+ | otherwise = Nothing
+
+lookup' :: [T.Text] -> J.Value -> Maybe J.Value
+lookup' [] v = Just v
+lookup' (k : ks) (J.Object kvs) =
+ lookup' ks =<< JM.lookup (JK.fromText k) kvs
+
+type Records a = [Record a]
+
+lookups :: Field -> Records J.Value -> Maybe J.Value
+lookups f rs =
+ case mapMaybe (lookup f) rs of
+ [] -> Nothing
+ [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)
+
+disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
+disjointUnion' _ (J.Object r) (J.Object s) =
+ J.Object (JM.unionWithKey disjointUnion' r s)
+disjointUnion' k _ _ =
+ throw (DuplicateField (JK.toString k))
+
+disjointUnions :: [J.Value] -> J.Value
+disjointUnions = foldl' disjointUnion (J.Object JM.empty)
diff --git a/app/Query/Type.hs b/app/Query/Type.hs
new file mode 100644
index 0000000..d27106f
--- /dev/null
+++ b/app/Query/Type.hs
@@ -0,0 +1,62 @@
+module Query.Type
+ ( module Query.Field,
+ module Query.Record,
+ Collection,
+ Comparison (..),
+ EmbedClause (..),
+ EmbedClauses,
+ FieldSelector (..),
+ JoinClause (..),
+ JoinClauses,
+ JoinType (..),
+ Query (..),
+ WhereClause (..),
+ )
+where
+
+import Data.List.NonEmpty qualified as N
+import Query.Field
+import Query.Record
+
+data Query
+ = Select
+ FieldSelector
+ Collection
+ (JoinClauses FilePath)
+ (EmbedClauses FilePath)
+ (Maybe WhereClause)
+
+data FieldSelector
+ = All
+ | Only (N.NonEmpty Field)
+ deriving (Show)
+
+type Collection = FilePath
+
+type JoinClauses a = [JoinClause a]
+
+data JoinClause a
+ = JoinClause JoinType a (Maybe WhereClause)
+ deriving (Show)
+
+data JoinType
+ = JoinLeft
+ | JoinRight
+ | JoinFull
+ deriving (Show)
+
+type EmbedClauses a = [EmbedClause a]
+
+data EmbedClause a
+ = EmbedClause a (Maybe WhereClause)
+ deriving (Show)
+
+data WhereClause
+ = And [WhereClause]
+ | Or [WhereClause]
+ | Where Comparison
+ deriving (Show)
+
+data Comparison
+ = Eq Field Field
+ deriving (Show)
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 09:36:30 +0000