diff options
Diffstat (limited to 'app/Main.hs')
| -rw-r--r-- | app/Main.hs | 364 |
1 files changed, 7 insertions, 357 deletions
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 |