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, 0 insertions, 360 deletions
diff --git a/app/Query/Field.hs b/app/Query/Field.hs
deleted file mode 100644
index cdb977a..0000000
--- a/app/Query/Field.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-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
deleted file mode 100644
index f2012e2..0000000
--- a/app/Query/Parser.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# 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
deleted file mode 100644
index e43b7d0..0000000
--- a/app/Query/Printer.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# 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
deleted file mode 100644
index b1b3329..0000000
--- a/app/Query/Record.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-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
deleted file mode 100644
index d27106f..0000000
--- a/app/Query/Type.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-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 20:57:26 +0000