diff options
| -rw-r--r-- | app/Debug.hs | 5 | ||||
| -rw-r--r-- | app/Exception.hs | 14 | ||||
| -rw-r--r-- | app/Main.hs | 364 | ||||
| -rw-r--r-- | app/Query.hs | 137 | ||||
| -rw-r--r-- | app/Query/Field.hs (renamed from app/Field.hs) | 2 | ||||
| -rw-r--r-- | app/Query/Parser.hs | 126 | ||||
| -rw-r--r-- | app/Query/Printer.hs | 60 | ||||
| -rw-r--r-- | app/Query/Record.hs (renamed from app/Record.hs) | 18 | ||||
| -rw-r--r-- | app/Query/Type.hs | 62 | ||||
| -rw-r--r-- | app/Store.hs | 6 | ||||
| -rw-r--r-- | json2sql.cabal | 24 |
11 files changed, 437 insertions, 381 deletions
diff --git a/app/Debug.hs b/app/Debug.hs index b28a967..3499e02 100644 --- a/app/Debug.hs +++ b/app/Debug.hs @@ -1,4 +1,7 @@ -module Debug where +module Debug + ( debug, + ) +where import Debug.Trace (trace) import Text.Printf (printf) diff --git a/app/Exception.hs b/app/Exception.hs index d67a8bc..0cccf5b 100644 --- a/app/Exception.hs +++ b/app/Exception.hs @@ -1,11 +1,23 @@ module Exception - ( DuplicateField (DuplicateField), + ( DecodeException (DecodeException), + DuplicateField (DuplicateField), + ParseError (ParseError), ) where import Control.Exception (Exception) +data DecodeException = DecodeException + deriving (Show) + +instance Exception DecodeException + data DuplicateField = DuplicateField String deriving (Show) instance Exception DuplicateField + +data ParseError = ParseError String + deriving (Show) + +instance Exception ParseError diff --git a/app/Main.hs b/app/Main.hs index e7d62bf..7bf67ba 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,33 +1,12 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Main + ( main, + ) +where -module Main where - -import Control.Exception (Exception, throw) -import Control.Monad (void) -import Control.Monad.Combinators.NonEmpty qualified as PN 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.Char (isSpace) -import Data.List (intercalate, isSuffixOf) -import Data.List.NonEmpty qualified as N -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) -import Data.String (IsString (fromString)) -import Data.Text qualified as T -import Data.Vector qualified as V -import Data.Void (Void) -import Field qualified as F -import Record qualified as R -import Store qualified as S +import Query qualified as Q 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 () @@ -47,334 +26,5 @@ main = do "SELECT c.id, j FROM c EMBED j ON j.id == c.j_id" ] -data Query - = Select - FieldSelector - Collection - (JoinClauses FilePath) - (EmbedClauses FilePath) - (Maybe WhereClause) - -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 = F.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] - -data FieldSelector - = All - | Only (N.NonEmpty F.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 F.Field F.Field - deriving (Show) - -data ParseError = ParseError String - deriving (Show) - -instance Exception ParseError - -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 F.Field - field = - lexeme . P.choice $ - [ P.try - do - F.Qualified - <$> (fieldPart <* P.string ".") - <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")), - do - F.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 - ] - -query :: Query -> IO [J.Value] -query (Select fs c js es w) = do - c' <- - mapM (fmap (R.fromValue c) . decodeFile . (c </>)) =<< ls c - js' <- - mapM - ( \(JoinClause t c w) -> - fmap (\j' -> JoinClause t (map (R.fromValue c) j') w) . mapM (decodeFile . (c </>)) - =<< ls c - ) - js - es' <- - mapM - ( \(EmbedClause c w) -> - fmap (\e' -> EmbedClause (R.fromValue c e') w) . mapM (decodeFile . (c </>)) - =<< ls c - ) - es - pure $ map (select fs) $ where_ w $ embed es' $ join c' js' - where - ls c = - filter (not . (isSuffixOf "/")) - <$> S.withStore "." "HEAD" do - S.listDirectory c - --- TODO use fold -embed :: - EmbedClauses (R.Record [J.Value]) -> - [R.Records J.Value] -> - [R.Records J.Value] -embed es vss = embed' vss es - where - embed' vss [] = vss - embed' vss (EmbedClause (R.Record c es) w : ess) = - embed' - ( map - ( \vs -> - let es' :: [J.Value] - es' = filter (\e -> satisfies w (vs ++ [R.Record c e])) es - in vs - ++ [ R.Record - c - ( J.Object - ( JM.singleton - (JK.fromString c) - (J.Array (V.fromList es')) - ) - ) - ] - ) - vss - ) - ess - --- TODO use fold -join :: - R.Records J.Value -> - JoinClauses (R.Records J.Value) -> - [R.Records J.Value] -join vs js = join' (map (: []) vs) js - where - join' vss [] = vss - join' vss (JoinClause JoinLeft js w : jss) = - join' - ( concatMap - ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of - [] -> [vs] - vs' -> vs' - ) - vss - ) - jss - join' vss (JoinClause JoinRight js w : jss) = - join' - ( concatMap - ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of - [] -> [[j]] - vs' -> vs' - ) - js - ) - jss - join' vss (JoinClause JoinFull js w : jss) = - join' - ( concatMap - ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of - [] -> [vs] - vs' -> vs' - ) - vss - ++ concatMap - ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of - [] -> [[j]] - _ -> [] - ) - js - ) - jss - -data DecodeException = DecodeException - deriving (Show) - -instance Exception DecodeException - -decodeFile :: J.FromJSON a => Collection -> IO a -decodeFile fp = S.withStore "." "HEAD" do - fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp - -select :: FieldSelector -> R.Records J.Value -> J.Value -select All vs = R.disjointUnions (map R.toValue vs) -select (Only fs) vs = R.select (N.toList fs) vs - -where_ :: Maybe WhereClause -> [R.Records J.Value] -> [R.Records J.Value] -where_ w = filter (satisfies w) - -satisfies :: Maybe WhereClause -> R.Records J.Value -> Bool -satisfies Nothing _ = True -satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws -satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws -satisfies (Just (Where (Eq f g))) vs = R.lookups f vs == R.lookups g vs - -query' :: Query -> IO () -query' q = mapM_ (LB.putStrLn . J.encode) =<< query q +query' :: Q.Query -> IO () +query' q = mapM_ (LB.putStrLn . J.encode) =<< Q.query q diff --git a/app/Query.hs b/app/Query.hs new file mode 100644 index 0000000..8f0eda6 --- /dev/null +++ b/app/Query.hs @@ -0,0 +1,137 @@ +module Query + ( module Query.Type, + query, + ) +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 (isSuffixOf) +import Data.List.NonEmpty qualified as N +import Data.Maybe (fromMaybe) +import Data.Vector qualified as V +import Exception (DecodeException (DecodeException)) +import Query.Parser () +import Query.Printer () +import Query.Record +import Query.Type +import Store qualified as S +import System.FilePath ((</>)) + +query :: Query -> IO [J.Value] +query (Select fs c js es w) = do + c' <- + mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c + js' <- + mapM + ( \(JoinClause t c w) -> + fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>)) + =<< ls c + ) + js + es' <- + mapM + ( \(EmbedClause c w) -> + fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>)) + =<< ls c + ) + es + pure $ map (Query.select fs) $ where_ w $ embed es' $ join c' js' + where + ls c = + filter (not . (isSuffixOf "/")) + <$> S.withStore "." "HEAD" do + S.listDirectory c + +-- TODO use fold +embed :: + EmbedClauses (Record [J.Value]) -> + [Records J.Value] -> + [Records J.Value] +embed es vss = embed' vss es + where + embed' vss [] = vss + embed' vss (EmbedClause (Record c es) w : ess) = + embed' + ( map + ( \vs -> + let es' :: [J.Value] + es' = filter (\e -> satisfies w (vs ++ [Record c e])) es + in vs + ++ [ Record + c + ( J.Object + ( JM.singleton + (JK.fromString c) + (J.Array (V.fromList es')) + ) + ) + ] + ) + vss + ) + ess + +-- TODO use fold +join :: + Records J.Value -> + JoinClauses (Records J.Value) -> + [Records J.Value] +join vs js = join' (map (: []) vs) js + where + join' vss [] = vss + join' vss (JoinClause JoinLeft js w : jss) = + join' + ( concatMap + ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of + [] -> [vs] + vs' -> vs' + ) + vss + ) + jss + join' vss (JoinClause JoinRight js w : jss) = + join' + ( concatMap + ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of + [] -> [[j]] + vs' -> vs' + ) + js + ) + jss + join' vss (JoinClause JoinFull js w : jss) = + join' + ( concatMap + ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of + [] -> [vs] + vs' -> vs' + ) + vss + ++ concatMap + ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of + [] -> [[j]] + _ -> [] + ) + js + ) + jss + +select :: FieldSelector -> Records J.Value -> J.Value +select All vs = disjointUnions (map toValue vs) +select (Only fs) vs = Query.Record.select (N.toList fs) vs + +where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value] +where_ w = filter (satisfies w) + +satisfies :: Maybe WhereClause -> Records J.Value -> Bool +satisfies Nothing _ = True +satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws +satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws +satisfies (Just (Where (Eq f g))) vs = lookups f vs == lookups g vs + +decodeFile :: J.FromJSON a => Collection -> IO a +decodeFile fp = S.withStore "." "HEAD" do + fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp diff --git a/app/Field.hs b/app/Query/Field.hs index 68baec7..cdb977a 100644 --- a/app/Field.hs +++ b/app/Query/Field.hs @@ -1,4 +1,4 @@ -module Field +module Query.Field ( Field (..), toString, prefix, 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/Record.hs b/app/Query/Record.hs index 30e98ec..b1b3329 100644 --- a/app/Record.hs +++ b/app/Query/Record.hs @@ -1,4 +1,4 @@ -module Record +module Query.Record ( Record (..), fromValue, toValue, @@ -20,7 +20,7 @@ import Data.List.NonEmpty qualified as N import Data.Maybe (fromMaybe, mapMaybe) import Data.Text qualified as T import Exception (DuplicateField (DuplicateField)) -import Field qualified as F +import Query.Field import Prelude hiding (lookup) data Record a @@ -35,10 +35,10 @@ fromValue = Record toValue :: Record a -> a toValue (Record _ v) = v -lookup :: F.Field -> Record J.Value -> Maybe J.Value -lookup (F.Unqualified ks) (Record _ v) = +lookup :: Field -> Record J.Value -> Maybe J.Value +lookup (Unqualified ks) (Record _ v) = lookup' (N.toList ks) v -lookup (F.Qualified c' ks) (Record c v) +lookup (Qualified c' ks) (Record c v) | c' == c = lookup' (N.toList ks) v | otherwise = Nothing @@ -49,19 +49,19 @@ lookup' (k : ks) (J.Object kvs) = type Records a = [Record a] -lookups :: F.Field -> Records J.Value -> Maybe J.Value +lookups :: Field -> Records J.Value -> Maybe J.Value lookups f rs = case mapMaybe (lookup f) rs of [] -> Nothing [v] -> Just v - (_ : _) -> throw (DuplicateField (F.toString f)) + (_ : _) -> throw (DuplicateField (toString f)) -select :: [F.Field] -> Records J.Value -> J.Value +select :: [Field] -> Records J.Value -> J.Value select fs rs = foldl' union (J.Object JM.empty) - (map (\f -> F.prefix f ((fromMaybe J.Null (lookups f rs)))) fs) + (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) 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) diff --git a/app/Store.hs b/app/Store.hs index 3e0f3d3..3a899b6 100644 --- a/app/Store.hs +++ b/app/Store.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - module Store ( withStore, listDirectory, diff --git a/json2sql.cabal b/json2sql.cabal index aab906b..1cfd4da 100644 --- a/json2sql.cabal +++ b/json2sql.cabal @@ -12,17 +12,21 @@ build-type: Simple extra-doc-files: CHANGELOG.md -- extra-source-files: -common warnings - ghc-options: -Wall - executable json2sql - import: warnings + ghc-options: + -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing main-is: Main.hs other-modules: Debug Exception - Field - Record + Query + Query.Field + Query.Parser + Query.Printer + Query.Record + Query.Type Store -- other-extensions: build-depends: base ^>=4.16.4.0, @@ -46,3 +50,11 @@ executable json2sql vector hs-source-dirs: app default-language: GHC2021 + default-extensions: + AllowAmbiguousTypes + BlockArguments + GeneralizedNewtypeDeriving + OverloadedRecordDot + OverloadedStrings + ViewPatterns + |